1# -*- tcl -*- 2# Functionality covered: operation of all IO commands, and all procedures 3# defined in generic/tclIO.c. 4# 5# This file contains a collection of tests for one or more of the Tcl built-in 6# commands. Sourcing this file into Tcl runs the tests and generates output 7# for errors. No output means no errors were found. 8# 9# Copyright © 1991-1994 The Regents of the University of California. 10# Copyright © 1994-1997 Sun Microsystems, Inc. 11# Copyright © 1998-1999 Scriptics Corporation. 12# 13# See the file "license.terms" for information on usage and redistribution of 14# this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16if {"::tcltest" ni [namespace children]} { 17 package require tcltest 2.5 18 namespace import -force ::tcltest::* 19} 20 21namespace eval ::tcl::test::io { 22 23 if {"::tcltest" ni [namespace children]} { 24 package require tcltest 2.5 25 namespace import -force ::tcltest::* 26 } 27 28 variable umaskValue 29 variable path 30 variable f 31 variable i 32 variable n 33 variable v 34 variable msg 35 variable expected 36 37 catch { 38 ::tcltest::loadTestedCommands 39 package require -exact tcl::test [info patchlevel] 40 set ::tcltestlib [info loaded {} Tcltest] 41 } 42 package require tcltests 43 44 testConstraint testbytestring [llength [info commands testbytestring]] 45 testConstraint testchannel [llength [info commands testchannel]] 46 testConstraint testfevent [llength [info commands testfevent]] 47 testConstraint testchannelevent [llength [info commands testchannelevent]] 48 testConstraint testmainthread [llength [info commands testmainthread]] 49 testConstraint testservicemode [llength [info commands testservicemode]] 50 testConstraint notWinCI [expr { 51 $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] 52 testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] 53 54 # You need a *very* special environment to do some tests. In particular, 55 # many file systems do not support large-files... 56 testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] 57 58 # some tests can only be run is umask is 2 if "umask" cannot be run, the 59 # tests will be skipped. 60 set umaskValue 0 61 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] 62 63 testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] 64 65 # set up a long data file for some of the following tests 66 67 set path(longfile) [makeFile {} longfile] 68 set f [open $path(longfile) w] 69 chan configure $f -eofchar {} -translation lf 70 for { set i 0 } { $i < 100 } { incr i} { 71 chan puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef 72\#123456789abcdef01 73\#" 74 } 75 chan close $f 76 77 set path(cat) [makeFile { 78 set f stdin 79 if {$argv != ""} { 80 set f [open [lindex $argv 0]] 81 } 82 chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A 83 chan configure stdout -encoding binary -translation lf -buffering none 84 chan event $f readable "foo $f" 85 proc foo {f} { 86 set x [chan read $f] 87 catch {chan puts -nonewline $x} 88 if {[chan eof $f]} { 89 chan close $f 90 exit 0 91 } 92 } 93 vwait forever 94 } cat] 95 96 set thisScript [file join [pwd] [info script]] 97 98 proc contents {file} { 99 set f [open $file] 100 chan configure $f -translation binary 101 set a [chan read $f] 102 chan close $f 103 return $a 104 } 105 106 # Wrapper round butt-ugly pipe syntax 107 proc openpipe {{mode r+} args} { 108 open "|[list [interpreter] {*}$args]" $mode 109 } 110 111test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { 112 # no test, need to cause an async error. 113} {} 114set path(test1) [makeFile {} test1] 115test chan-io-1.6 {Tcl_WriteChars: WriteBytes} { 116 set f [open $path(test1) w] 117 chan configure $f -encoding binary 118 chan puts -nonewline $f "a乍\x00" 119 chan close $f 120 contents $path(test1) 121} "aM\x00" 122test chan-io-1.7 {Tcl_WriteChars: WriteChars} { 123 set f [open $path(test1) w] 124 chan configure $f -encoding shiftjis 125 chan puts -nonewline $f "a乍\x00" 126 chan close $f 127 contents $path(test1) 128} "a\x93\xE1\x00" 129set path(test2) [makeFile {} test2] 130test chan-io-1.8 {Tcl_WriteChars: WriteChars} { 131 # This test written for SF bug #506297. 132 # 133 # Executing this test without the fix for the referenced bug applied to 134 # tcl will cause tcl, more specifically WriteChars, to go into an infinite 135 # loop. 136 set f [open $path(test2) w] 137 chan configure $f -encoding iso2022-jp 138 chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] 139 chan close $f 140 contents $path(test2) 141} " \x1B\$B\$O\x1B(B" 142test chan-io-1.9 {Tcl_WriteChars: WriteChars} { 143 # When closing a channel with an encoding that appends escape bytes, check 144 # for the case where the escape bytes overflow the current IO buffer. The 145 # bytes should be moved into a new buffer. 146 set data "1234567890 [format %c 12399]" 147 set sizes [list] 148 # With default buffer size 149 set f [open $path(test2) w] 150 chan configure $f -encoding iso2022-jp 151 chan puts -nonewline $f $data 152 chan close $f 153 lappend sizes [file size $path(test2)] 154 # With buffer size equal to the length of the data, the escape bytes would 155 # go into the next buffer. 156 set f [open $path(test2) w] 157 chan configure $f -encoding iso2022-jp -buffersize 16 158 chan puts -nonewline $f $data 159 chan close $f 160 lappend sizes [file size $path(test2)] 161 # With buffer size that is large enough to hold 1 byte of escaped data, 162 # but not all 3. This should not write the escape bytes to the first 163 # buffer and then again to the second buffer. 164 set f [open $path(test2) w] 165 chan configure $f -encoding iso2022-jp -buffersize 17 166 chan puts -nonewline $f $data 167 chan close $f 168 lappend sizes [file size $path(test2)] 169 # With buffer size that can hold 2 out of 3 bytes of escaped data. 170 set f [open $path(test2) w] 171 chan configure $f -encoding iso2022-jp -buffersize 18 172 chan puts -nonewline $f $data 173 chan close $f 174 lappend sizes [file size $path(test2)] 175 # With buffer size that can hold all the data and escape bytes. 176 set f [open $path(test2) w] 177 chan configure $f -encoding iso2022-jp -buffersize 19 178 chan puts -nonewline $f $data 179 chan close $f 180 lappend sizes [file size $path(test2)] 181} {19 19 19 19 19} 182 183test chan-io-2.1 {WriteBytes} { 184 # loop until all bytes are written 185 set f [open $path(test1) w] 186 chan configure $f -encoding binary -buffersize 16 -translation crlf 187 chan puts $f "abcdefghijklmnopqrstuvwxyz" 188 chan close $f 189 contents $path(test1) 190} "abcdefghijklmnopqrstuvwxyz\r\n" 191test chan-io-2.2 {WriteBytes: savedLF > 0} { 192 # After flushing buffer, there was a \n left over from the last 193 # \n -> \r\n expansion. It gets stuck at beginning of this buffer. 194 set f [open $path(test1) w] 195 chan configure $f -encoding binary -buffersize 16 -translation crlf 196 chan puts -nonewline $f "123456789012345\n12" 197 set x [list [contents $path(test1)]] 198 chan close $f 199 lappend x [contents $path(test1)] 200} [list "123456789012345\r" "123456789012345\r\n12"] 201test chan-io-2.3 {WriteBytes: flush on line} -body { 202 # Tcl "line" buffering has weird behavior: if current buffer contains a 203 # \n, entire buffer gets flushed. Logical behavior would be to flush only 204 # up to the \n. 205 set f [open $path(test1) w] 206 chan configure $f -encoding binary -buffering line -translation crlf 207 chan puts -nonewline $f "\n12" 208 contents $path(test1) 209} -cleanup { 210 chan close $f 211} -result "\r\n12" 212test chan-io-2.4 {WriteBytes: reset sawLF after each buffer} { 213 set f [open $path(test1) w] 214 chan configure $f -encoding binary -buffering line -translation lf \ 215 -buffersize 16 216 chan puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" 217 set x [list [contents $path(test1)]] 218 chan close $f 219 lappend x [contents $path(test1)] 220} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] 221 222test chan-io-3.1 {WriteChars: compatibility with WriteBytes} { 223 # loop until all bytes are written 224 set f [open $path(test1) w] 225 chan configure $f -encoding ascii -buffersize 16 -translation crlf 226 chan puts $f "abcdefghijklmnopqrstuvwxyz" 227 chan close $f 228 contents $path(test1) 229} "abcdefghijklmnopqrstuvwxyz\r\n" 230test chan-io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { 231 # After flushing buffer, there was a \n left over from the last 232 # \n -> \r\n expansion. It gets stuck at beginning of this buffer. 233 set f [open $path(test1) w] 234 chan configure $f -encoding ascii -buffersize 16 -translation crlf 235 chan puts -nonewline $f "123456789012345\n12" 236 set x [list [contents $path(test1)]] 237 chan close $f 238 lappend x [contents $path(test1)] 239} [list "123456789012345\r" "123456789012345\r\n12"] 240test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -body { 241 # Tcl "line" buffering has weird behavior: if current buffer contains a 242 # \n, entire buffer gets flushed. Logical behavior would be to flush only 243 # up to the \n. 244 set f [open $path(test1) w] 245 chan configure $f -encoding ascii -buffering line -translation crlf 246 chan puts -nonewline $f "\n12" 247 contents $path(test1) 248} -cleanup { 249 chan close $f 250} -result "\r\n12" 251test chan-io-3.4 {WriteChars: loop over stage buffer} { 252 # stage buffer maps to more than can be queued at once. 253 set f [open $path(test1) w] 254 chan configure $f -encoding jis0208 -buffersize 16 255 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" 256 set x [list [contents $path(test1)]] 257 chan close $f 258 lappend x [contents $path(test1)] 259} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] 260test chan-io-3.5 {WriteChars: saved != 0} { 261 # Bytes produced by UtfToExternal from end of last channel buffer had to 262 # be moved to beginning of next channel buffer to preserve requested 263 # buffersize. 264 set f [open $path(test1) w] 265 chan configure $f -encoding jis0208 -buffersize 17 266 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" 267 set x [list [contents $path(test1)]] 268 chan close $f 269 lappend x [contents $path(test1)] 270} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] 271test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { 272 # One incomplete UTF-8 character at end of staging buffer. Backup in src 273 # to the beginning of that UTF-8 character and try again. 274 # 275 # Translate the first 16 bytes, produce 14 bytes of output, 2 left over 276 # (first two bytes of A in UTF-8). Given those two bytes try 277 # translating them again, find that no bytes are read produced, and break 278 # to outer loop where those two bytes will have the remaining 4 bytes (the 279 # last byte of A plus the all of B) appended. 280 set f [open $path(test1) w] 281 chan configure $f -encoding shiftjis -buffersize 16 282 chan puts -nonewline $f "12345678901234AB" 283 set x [list [contents $path(test1)]] 284 chan close $f 285 lappend x [contents $path(test1)] 286} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] 287test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { 288 # When translating UTF-8 to external, the produced bytes went past end of 289 # the channel buffer. This is done on purpose - we then truncate the bytes 290 # at the end of the partial character to preserve the requested blocksize 291 # on flush. The truncated bytes are moved to the beginning of the next 292 # channel buffer. 293 set f [open $path(test1) w] 294 chan configure $f -encoding jis0208 -buffersize 17 295 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" 296 set x [list [contents $path(test1)]] 297 chan close $f 298 lappend x [contents $path(test1)] 299} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] 300test chan-io-3.8 {WriteChars: reset sawLF after each buffer} { 301 set f [open $path(test1) w] 302 chan configure $f -encoding ascii -buffering line -translation lf \ 303 -buffersize 16 304 chan puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" 305 set x [list [contents $path(test1)]] 306 chan close $f 307 lappend x [contents $path(test1)] 308} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] 309 310test chan-io-4.1 {TranslateOutputEOL: lf} { 311 # search for \n 312 set f [open $path(test1) w] 313 chan configure $f -buffering line -translation lf 314 chan puts $f "abcde" 315 set x [list [contents $path(test1)]] 316 chan close $f 317 lappend x [contents $path(test1)] 318} [list "abcde\n" "abcde\n"] 319test chan-io-4.2 {TranslateOutputEOL: cr} { 320 # search for \n, replace with \r 321 set f [open $path(test1) w] 322 chan configure $f -buffering line -translation cr 323 chan puts $f "abcde" 324 set x [list [contents $path(test1)]] 325 chan close $f 326 lappend x [contents $path(test1)] 327} [list "abcde\r" "abcde\r"] 328test chan-io-4.3 {TranslateOutputEOL: crlf} { 329 # simple case: search for \n, replace with \r 330 set f [open $path(test1) w] 331 chan configure $f -buffering line -translation crlf 332 chan puts $f "abcde" 333 set x [list [contents $path(test1)]] 334 chan close $f 335 lappend x [contents $path(test1)] 336} [list "abcde\r\n" "abcde\r\n"] 337test chan-io-4.4 {TranslateOutputEOL: crlf} { 338 # Keep storing more bytes in output buffer until output buffer is full. We 339 # have 13 bytes initially that would turn into 18 bytes. Fill dest buffer 340 # while (dstEnd < dstMax). 341 set f [open $path(test1) w] 342 chan configure $f -translation crlf -buffersize 16 343 chan puts -nonewline $f "1234567\n\n\n\n\nA" 344 set x [list [contents $path(test1)]] 345 chan close $f 346 lappend x [contents $path(test1)] 347} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"] 348test chan-io-4.5 {TranslateOutputEOL: crlf} { 349 # Check for overflow of the destination buffer 350 set f [open $path(test1) w] 351 chan configure $f -translation crlf -buffersize 12 352 chan puts -nonewline $f "12345678901\n456789012345678901234" 353 chan close $f 354 set x [contents $path(test1)] 355} "12345678901\r\n456789012345678901234" 356 357test chan-io-5.1 {CheckFlush: not full} { 358 set f [open $path(test1) w] 359 chan configure $f 360 chan puts -nonewline $f "12345678901234567890" 361 set x [list [contents $path(test1)]] 362 chan close $f 363 lappend x [contents $path(test1)] 364} [list "" "12345678901234567890"] 365test chan-io-5.2 {CheckFlush: full} { 366 set f [open $path(test1) w] 367 chan configure $f -buffersize 16 368 chan puts -nonewline $f "12345678901234567890" 369 set x [list [contents $path(test1)]] 370 chan close $f 371 lappend x [contents $path(test1)] 372} [list "1234567890123456" "12345678901234567890"] 373test chan-io-5.3 {CheckFlush: not line} { 374 set f [open $path(test1) w] 375 chan configure $f -buffering line 376 chan puts -nonewline $f "12345678901234567890" 377 set x [list [contents $path(test1)]] 378 chan close $f 379 lappend x [contents $path(test1)] 380} [list "" "12345678901234567890"] 381test chan-io-5.4 {CheckFlush: line} { 382 set f [open $path(test1) w] 383 chan configure $f -buffering line -translation lf -encoding ascii 384 chan puts -nonewline $f "1234567890\n1234567890" 385 set x [list [contents $path(test1)]] 386 chan close $f 387 lappend x [contents $path(test1)] 388} [list "1234567890\n1234567890" "1234567890\n1234567890"] 389test chan-io-5.5 {CheckFlush: none} { 390 set f [open $path(test1) w] 391 chan configure $f -buffering none 392 chan puts -nonewline $f "1234567890" 393 set x [list [contents $path(test1)]] 394 chan close $f 395 lappend x [contents $path(test1)] 396} [list "1234567890" "1234567890"] 397 398test chan-io-6.1 {Tcl_GetsObj: working} -body { 399 set f [open $path(test1) w] 400 chan puts $f "foo\nboo" 401 chan close $f 402 set f [open $path(test1)] 403 chan gets $f 404} -cleanup { 405 chan close $f 406} -result {foo} 407test chan-io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} emptyTest { 408 # no test, need to cause an async error. 409} {} 410test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body { 411 # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved} 412 set f [open $path(test1) w] 413 chan configure $f -translation crlf 414 chan puts $f "abc\ndefg" 415 chan close $f 416 set f [open $path(test1)] 417 list [chan tell $f] [chan gets $f line] [chan tell $f] [chan gets $f line] $line 418} -cleanup { 419 chan close $f 420} -result {0 3 5 4 defg} 421test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body { 422 set f [open $path(test1) w] 423 chan configure $f -translation binary 424 chan puts $f "\x81\u1234\x00" 425 chan close $f 426 set f [open $path(test1)] 427 chan configure $f -translation binary 428 list [chan gets $f line] $line 429} -cleanup { 430 chan close $f 431} -result [list 3 "\x81\x34\x00"] 432test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} -body { 433 set f [open $path(test1) w] 434 chan configure $f -translation binary 435 chan puts $f "\x88\xEA\x92\x9A" 436 chan close $f 437 set f [open $path(test1)] 438 chan configure $f -encoding shiftjis 439 list [chan gets $f line] $line 440} -cleanup { 441 chan close $f 442} -result [list 2 "一丁"] 443set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" 444append a $a 445append a $a 446test chan-io-6.6 {Tcl_GetsObj: loop test} -body { 447 # if (dst >= dstEnd) 448 set f [open $path(test1) w] 449 chan puts $f $a 450 chan puts $f hi 451 chan close $f 452 set f [open $path(test1)] 453 list [chan gets $f line] $line 454} -cleanup { 455 chan close $f 456} -result [list 256 $a] 457test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints stdio -body { 458 # if (FilterInputBytes(chanPtr, &gs) != 0) 459 set f [openpipe w+ $path(cat)] 460 chan puts -nonewline $f "hi\nwould" 461 chan flush $f 462 chan gets $f 463 chan configure $f -blocking 0 464 chan gets $f line 465} -cleanup { 466 chan close $f 467} -result {-1} 468test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body { 469 set f [open $path(test1) w] 470 chan puts $f "abcdef\x1Aghijk\nwombat" 471 chan close $f 472 set f [open $path(test1)] 473 chan configure $f -eofchar \x1A 474 list [chan gets $f line] $line [chan gets $f line] $line 475} -cleanup { 476 chan close $f 477} -result {6 abcdef -1 {}} 478test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body { 479 set f [open $path(test1) w] 480 chan puts $f "abcdefghijk\nwom\x1Abat" 481 chan close $f 482 set f [open $path(test1)] 483 chan configure $f -eofchar \x1A 484 list [chan gets $f line] $line [chan gets $f line] $line 485} -cleanup { 486 chan close $f 487} -result {11 abcdefghijk 3 wom} 488# Comprehensive tests 489test chan-io-6.10 {Tcl_GetsObj: lf mode: no chars} -body { 490 set f [open $path(test1) w] 491 chan close $f 492 set f [open $path(test1)] 493 chan configure $f -translation lf 494 list [chan gets $f line] $line 495} -cleanup { 496 chan close $f 497} -result {-1 {}} 498test chan-io-6.11 {Tcl_GetsObj: lf mode: lone \n} -body { 499 set f [open $path(test1) w] 500 chan configure $f -translation lf 501 chan puts -nonewline $f "\n" 502 chan close $f 503 set f [open $path(test1)] 504 chan configure $f -translation lf 505 list [chan gets $f line] $line [chan gets $f line] $line 506} -cleanup { 507 chan close $f 508} -result {0 {} -1 {}} 509test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} -body { 510 set f [open $path(test1) w] 511 chan configure $f -translation lf 512 chan puts -nonewline $f "\r" 513 chan close $f 514 set f [open $path(test1)] 515 chan configure $f -translation lf 516 set x [list [chan gets $f line] $line [chan gets $f line] $line] 517} -cleanup { 518 chan close $f 519} -result [list 1 "\r" -1 ""] 520test chan-io-6.13 {Tcl_GetsObj: lf mode: 1 char} -body { 521 set f [open $path(test1) w] 522 chan configure $f -translation lf 523 chan puts -nonewline $f a 524 chan close $f 525 set f [open $path(test1)] 526 chan configure $f -translation lf 527 list [chan gets $f line] $line [chan gets $f line] $line 528} -cleanup { 529 chan close $f 530} -result {1 a -1 {}} 531test chan-io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} -body { 532 set f [open $path(test1) w] 533 chan configure $f -translation lf 534 chan puts -nonewline $f "a\n" 535 chan close $f 536 set f [open $path(test1)] 537 chan configure $f -translation lf 538 list [chan gets $f line] $line [chan gets $f line] $line 539} -cleanup { 540 chan close $f 541} -result {1 a -1 {}} 542test chan-io-6.15 {Tcl_GetsObj: lf mode: several chars} -body { 543 set f [open $path(test1) w] 544 chan configure $f -translation lf 545 chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" 546 chan close $f 547 set f [open $path(test1)] 548 chan configure $f -translation lf 549 list [chan gets $f line] $line [chan gets $f line] $line \ 550 [chan gets $f line] $line [chan gets $f line] $line 551} -cleanup { 552 chan close $f 553} -result [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""] 554test chan-io-6.16 {Tcl_GetsObj: cr mode: no chars} -body { 555 set f [open $path(test1) w] 556 chan close $f 557 set f [open $path(test1)] 558 chan configure $f -translation cr 559 list [chan gets $f line] $line 560} -cleanup { 561 chan close $f 562} -result {-1 {}} 563test chan-io-6.17 {Tcl_GetsObj: cr mode: lone \n} -body { 564 set f [open $path(test1) w] 565 chan configure $f -translation lf 566 chan puts -nonewline $f "\n" 567 chan close $f 568 set f [open $path(test1)] 569 chan configure $f -translation cr 570 list [chan gets $f line] $line [chan gets $f line] $line 571} -cleanup { 572 chan close $f 573} -result [list 1 "\n" -1 ""] 574test chan-io-6.18 {Tcl_GetsObj: cr mode: lone \r} -body { 575 set f [open $path(test1) w] 576 chan configure $f -translation lf 577 chan puts -nonewline $f "\r" 578 chan close $f 579 set f [open $path(test1)] 580 chan configure $f -translation cr 581 list [chan gets $f line] $line [chan gets $f line] $line 582} -cleanup { 583 chan close $f 584} -result {0 {} -1 {}} 585test chan-io-6.19 {Tcl_GetsObj: cr mode: 1 char} -body { 586 set f [open $path(test1) w] 587 chan configure $f -translation lf 588 chan puts -nonewline $f a 589 chan close $f 590 set f [open $path(test1)] 591 chan configure $f -translation cr 592 list [chan gets $f line] $line [chan gets $f line] $line 593} -cleanup { 594 chan close $f 595} -result {1 a -1 {}} 596test chan-io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} -body { 597 set f [open $path(test1) w] 598 chan configure $f -translation lf 599 chan puts -nonewline $f "a\r" 600 chan close $f 601 set f [open $path(test1)] 602 chan configure $f -translation cr 603 list [chan gets $f line] $line [chan gets $f line] $line 604} -cleanup { 605 chan close $f 606} -result {1 a -1 {}} 607test chan-io-6.21 {Tcl_GetsObj: cr mode: several chars} -body { 608 set f [open $path(test1) w] 609 chan configure $f -translation lf 610 chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" 611 chan close $f 612 set f [open $path(test1)] 613 chan configure $f -translation cr 614 list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line 615} -cleanup { 616 chan close $f 617} -result [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""] 618test chan-io-6.22 {Tcl_GetsObj: crlf mode: no chars} -body { 619 set f [open $path(test1) w] 620 chan close $f 621 set f [open $path(test1)] 622 chan configure $f -translation crlf 623 list [chan gets $f line] $line 624} -cleanup { 625 chan close $f 626} -result {-1 {}} 627test chan-io-6.23 {Tcl_GetsObj: crlf mode: lone \n} -body { 628 set f [open $path(test1) w] 629 chan configure $f -translation lf 630 chan puts -nonewline $f "\n" 631 chan close $f 632 set f [open $path(test1)] 633 chan configure $f -translation crlf 634 list [chan gets $f line] $line [chan gets $f line] $line 635} -cleanup { 636 chan close $f 637} -result [list 1 "\n" -1 ""] 638test chan-io-6.24 {Tcl_GetsObj: crlf mode: lone \r} -body { 639 set f [open $path(test1) w] 640 chan configure $f -translation lf 641 chan puts -nonewline $f "\r" 642 chan close $f 643 set f [open $path(test1)] 644 chan configure $f -translation crlf 645 list [chan gets $f line] $line [chan gets $f line] $line 646} -cleanup { 647 chan close $f 648} -result [list 1 "\r" -1 ""] 649test chan-io-6.25 {Tcl_GetsObj: crlf mode: \r\r} -body { 650 set f [open $path(test1) w] 651 chan configure $f -translation lf 652 chan puts -nonewline $f "\r\r" 653 chan close $f 654 set f [open $path(test1)] 655 chan configure $f -translation crlf 656 list [chan gets $f line] $line [chan gets $f line] $line 657} -cleanup { 658 chan close $f 659} -result [list 2 "\r\r" -1 ""] 660test chan-io-6.26 {Tcl_GetsObj: crlf mode: \r\n} -body { 661 set f [open $path(test1) w] 662 chan configure $f -translation lf 663 chan puts -nonewline $f "\r\n" 664 chan close $f 665 set f [open $path(test1)] 666 chan configure $f -translation crlf 667 list [chan gets $f line] $line [chan gets $f line] $line 668} -cleanup { 669 chan close $f 670} -result {0 {} -1 {}} 671test chan-io-6.27 {Tcl_GetsObj: crlf mode: 1 char} -body { 672 set f [open $path(test1) w] 673 chan configure $f -translation lf 674 chan puts -nonewline $f a 675 chan close $f 676 set f [open $path(test1)] 677 chan configure $f -translation crlf 678 list [chan gets $f line] $line [chan gets $f line] $line 679} -cleanup { 680 chan close $f 681} -result {1 a -1 {}} 682test chan-io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} -body { 683 set f [open $path(test1) w] 684 chan configure $f -translation lf 685 chan puts -nonewline $f "a\r\n" 686 chan close $f 687 set f [open $path(test1)] 688 chan configure $f -translation crlf 689 list [chan gets $f line] $line [chan gets $f line] $line 690} -cleanup { 691 chan close $f 692} -result {1 a -1 {}} 693test chan-io-6.29 {Tcl_GetsObj: crlf mode: several chars} -body { 694 set f [open $path(test1) w] 695 chan configure $f -translation lf 696 chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" 697 chan close $f 698 set f [open $path(test1)] 699 chan configure $f -translation crlf 700 list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line 701} -cleanup { 702 chan close $f 703} -result [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] 704test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} -constraints {testchannel} -body { 705 # if (eol >= dstEnd) 706 set f [open $path(test1) w] 707 chan configure $f -translation lf 708 chan puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz" 709 chan close $f 710 set f [open $path(test1)] 711 chan configure $f -translation crlf -buffersize 16 712 list [chan gets $f line] $line [testchannel inputbuffered $f] 713} -cleanup { 714 chan close $f 715} -result [list 15 "123456789012345" 15] 716test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup { 717 set x "" 718} -constraints {stdio testchannel fileevent} -body { 719 # (FilterInputBytes() != 0) 720 set f [openpipe w+ $path(cat)] 721 chan configure $f -translation {crlf lf} -buffering none 722 chan puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" 723 chan configure $f -buffersize 16 724 lappend x [chan gets $f] 725 chan configure $f -blocking 0 726 lappend x [chan gets $f line] $line [chan blocked $f] \ 727 [testchannel inputbuffered $f] 728} -cleanup { 729 chan close $f 730} -result {bbbbbbbbbbbbbb -1 {} 1 16} 731test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} -constraints {testchannel} -body { 732 # not (FilterInputBytes() != 0) 733 set f [open $path(test1) w] 734 chan configure $f -translation lf 735 chan puts -nonewline $f "123456789012345\r\n123" 736 chan close $f 737 set f [open $path(test1)] 738 chan configure $f -translation crlf -buffersize 16 739 list [chan gets $f line] $line [chan tell $f] [testchannel inputbuffered $f] 740} -cleanup { 741 chan close $f 742} -result {15 123456789012345 17 3} 743test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} -body { 744 # eol still equals dstEnd 745 set f [open $path(test1) w] 746 chan configure $f -translation lf 747 chan puts -nonewline $f "123456789012345\r" 748 chan close $f 749 set f [open $path(test1)] 750 chan configure $f -translation crlf -buffersize 16 751 list [chan gets $f line] $line [chan eof $f] 752} -cleanup { 753 chan close $f 754} -result [list 16 "123456789012345\r" 1] 755test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} -body { 756 # not (*eol == '\n') 757 set f [open $path(test1) w] 758 chan configure $f -translation lf 759 chan puts -nonewline $f "123456789012345\rabcd\r\nefg" 760 chan close $f 761 set f [open $path(test1)] 762 chan configure $f -translation crlf -buffersize 16 763 list [chan gets $f line] $line [chan tell $f] 764} -cleanup { 765 chan close $f 766} -result [list 20 "123456789012345\rabcd" 22] 767test chan-io-6.35 {Tcl_GetsObj: auto mode: no chars} -body { 768 set f [open $path(test1) w] 769 chan close $f 770 set f [open $path(test1)] 771 chan configure $f -translation auto 772 list [chan gets $f line] $line 773} -cleanup { 774 chan close $f 775} -result {-1 {}} 776test chan-io-6.36 {Tcl_GetsObj: auto mode: lone \n} -body { 777 set f [open $path(test1) w] 778 chan configure $f -translation lf 779 chan puts -nonewline $f "\n" 780 chan close $f 781 set f [open $path(test1)] 782 chan configure $f -translation auto 783 list [chan gets $f line] $line [chan gets $f line] $line 784} -cleanup { 785 chan close $f 786} -result {0 {} -1 {}} 787test chan-io-6.37 {Tcl_GetsObj: auto mode: lone \r} -body { 788 set f [open $path(test1) w] 789 chan configure $f -translation lf 790 chan puts -nonewline $f "\r" 791 chan close $f 792 set f [open $path(test1)] 793 chan configure $f -translation auto 794 list [chan gets $f line] $line [chan gets $f line] $line 795} -cleanup { 796 chan close $f 797} -result {0 {} -1 {}} 798test chan-io-6.38 {Tcl_GetsObj: auto mode: \r\r} -body { 799 set f [open $path(test1) w] 800 chan configure $f -translation lf 801 chan puts -nonewline $f "\r\r" 802 chan close $f 803 set f [open $path(test1)] 804 chan configure $f -translation auto 805 list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line 806} -cleanup { 807 chan close $f 808} -result {0 {} 0 {} -1 {}} 809test chan-io-6.39 {Tcl_GetsObj: auto mode: \r\n} -body { 810 set f [open $path(test1) w] 811 chan configure $f -translation lf 812 chan puts -nonewline $f "\r\n" 813 chan close $f 814 set f [open $path(test1)] 815 chan configure $f -translation auto 816 list [chan gets $f line] $line [chan gets $f line] $line 817} -cleanup { 818 chan close $f 819} -result {0 {} -1 {}} 820test chan-io-6.40 {Tcl_GetsObj: auto mode: 1 char} -body { 821 set f [open $path(test1) w] 822 chan configure $f -translation lf 823 chan puts -nonewline $f a 824 chan close $f 825 set f [open $path(test1)] 826 chan configure $f -translation auto 827 list [chan gets $f line] $line [chan gets $f line] $line 828} -cleanup { 829 chan close $f 830} -result {1 a -1 {}} 831test chan-io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} -body { 832 set f [open $path(test1) w] 833 chan configure $f -translation lf 834 chan puts -nonewline $f "a\r\n" 835 chan close $f 836 set f [open $path(test1)] 837 chan configure $f -translation auto 838 list [chan gets $f line] $line [chan gets $f line] $line 839} -cleanup { 840 chan close $f 841} -result {1 a -1 {}} 842test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} -setup { 843 set x "" 844} -body { 845 set f [open $path(test1) w] 846 chan configure $f -translation lf 847 chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" 848 chan close $f 849 set f [open $path(test1)] 850 chan configure $f -translation auto 851 lappend x [chan gets $f line] $line [chan gets $f line] $line 852 lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line 853} -cleanup { 854 chan close $f 855} -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}} 856test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { 857 set x "" 858} -constraints {stdio testchannel fileevent} -body { 859 # if (chanPtr->flags & INPUT_SAW_CR) 860 set f [openpipe w+ $path(cat)] 861 chan configure $f -translation {auto lf} -buffering none 862 chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" 863 chan configure $f -buffersize 16 864 lappend x [chan gets $f] 865 chan configure $f -blocking 0 866 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 867 chan configure $f -blocking 1 868 chan puts -nonewline $f "\nabcd\refg\x1A" 869 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 870 lappend x [chan gets $f line] $line 871} -cleanup { 872 chan close $f 873} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} 874test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { 875 set x "" 876} -constraints {stdio testchannel fileevent} -body { 877 # not (*eol == '\n') 878 set f [openpipe w+ $path(cat)] 879 chan configure $f -translation {auto lf} -buffering none 880 chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" 881 chan configure $f -buffersize 16 882 lappend x [chan gets $f] 883 chan configure $f -blocking 0 884 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 885 chan configure $f -blocking 1 886 chan puts -nonewline $f "abcd\refg\x1A" 887 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 888 lappend x [chan gets $f line] $line 889} -cleanup { 890 chan close $f 891} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} 892test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup { 893 set x "" 894} -constraints {stdio testchannel fileevent} -body { 895 # Tcl_ExternalToUtf() 896 set f [openpipe w+ $path(cat)] 897 chan configure $f -translation {auto lf} -buffering none 898 chan configure $f -encoding utf-16 899 chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" 900 chan configure $f -buffersize 16 901 chan gets $f 902 chan configure $f -blocking 0 903 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 904 chan configure $f -blocking 1 905 chan puts -nonewline $f "\nabcd\refg" 906 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 907} -cleanup { 908 chan close $f 909} -result {15 123456789abcdef 1 4 abcd 0} 910test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup { 911 set x "" 912} -constraints {stdio testchannel fileevent} -body { 913 # memmove() 914 set f [openpipe w+ $path(cat)] 915 chan configure $f -translation {auto lf} -buffering none 916 chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" 917 chan configure $f -buffersize 16 918 chan gets $f 919 chan configure $f -blocking 0 920 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 921 chan configure $f -blocking 1 922 chan puts -nonewline $f "\n\x1A" 923 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 924} -cleanup { 925 chan close $f 926} -result {15 123456789abcdef 1 -1 {} 0} 927test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} -constraints {testchannel} -body { 928 # (eol == dstEnd) 929 set f [open $path(test1) w] 930 chan configure $f -translation lf 931 chan puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq" 932 chan close $f 933 set f [open $path(test1)] 934 chan configure $f -translation auto -buffersize 16 935 list [chan gets $f] [testchannel inputbuffered $f] 936} -cleanup { 937 chan close $f 938} -result {123456789012345 15} 939test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} -constraints {testchannel} -body { 940 # PeekAhead() did not get any, so (eol >= dstEnd) 941 set f [open $path(test1) w] 942 chan configure $f -translation lf 943 chan puts -nonewline $f "123456789012345\r" 944 chan close $f 945 set f [open $path(test1)] 946 chan configure $f -translation auto -buffersize 16 947 list [chan gets $f] [testchannel queuedcr $f] 948} -cleanup { 949 chan close $f 950} -result {123456789012345 1} 951test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} -constraints {testchannel} -body { 952 # if (*eol == '\n') {skip++} 953 set f [open $path(test1) w] 954 chan configure $f -translation lf 955 chan puts -nonewline $f "123456\r\n78901" 956 chan close $f 957 set f [open $path(test1)] 958 list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] 959} -cleanup { 960 chan close $f 961} -result {123456 0 8 78901} 962test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} -constraints {testchannel} -body { 963 # not (*eol == '\n') 964 set f [open $path(test1) w] 965 chan configure $f -translation lf 966 chan puts -nonewline $f "123456\r78901" 967 chan close $f 968 set f [open $path(test1)] 969 list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] 970} -cleanup { 971 chan close $f 972} -result {123456 0 7 78901} 973test chan-io-6.51 {Tcl_GetsObj: auto mode: \n} -body { 974 # else if (*eol == '\n') {goto gotoeol;} 975 set f [open $path(test1) w] 976 chan configure $f -translation lf 977 chan puts -nonewline $f "123456\n78901" 978 chan close $f 979 set f [open $path(test1)] 980 list [chan gets $f] [chan tell $f] [chan gets $f] 981} -cleanup { 982 chan close $f 983} -result {123456 7 78901} 984test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -body { 985 # if (eof != NULL) 986 set f [open $path(test1) w] 987 chan configure $f -translation lf 988 chan puts -nonewline $f "123456\x1Ak9012345\r" 989 chan close $f 990 set f [open $path(test1)] 991 chan configure $f -eofchar \x1A 992 list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] 993} -cleanup { 994 chan close $f 995} -result {123456 0 6 {}} 996test chan-io-6.53 {Tcl_GetsObj: device EOF} -body { 997 # didn't produce any bytes 998 set f [open $path(test1) w] 999 chan close $f 1000 set f [open $path(test1)] 1001 list [chan gets $f line] $line [chan eof $f] 1002} -cleanup { 1003 chan close $f 1004} -result {-1 {} 1} 1005test chan-io-6.54 {Tcl_GetsObj: device EOF} -body { 1006 # got some bytes before EOF. 1007 set f [open $path(test1) w] 1008 chan puts -nonewline $f abc 1009 chan close $f 1010 set f [open $path(test1)] 1011 list [chan gets $f line] $line [chan eof $f] 1012} -cleanup { 1013 chan close $f 1014} -result {3 abc 1} 1015test chan-io-6.55 {Tcl_GetsObj: overconverted} -body { 1016 # Tcl_ExternalToUtf(), make sure state updated 1017 set f [open $path(test1) w] 1018 chan configure $f -encoding iso2022-jp 1019 chan puts $f "there一ok\n丁more bytes\nhere" 1020 chan close $f 1021 set f [open $path(test1)] 1022 chan configure $f -encoding iso2022-jp 1023 list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line 1024} -cleanup { 1025 chan close $f 1026} -result [list 8 "there一ok" 11 "丁more bytes" 4 "here"] 1027test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup { 1028 update 1029 variable x {} 1030} -constraints {stdio fileevent} -body { 1031 set f [openpipe w+ $path(cat)] 1032 chan configure $f -buffering none 1033 chan puts -nonewline $f "foobar" 1034 chan configure $f -blocking 0 1035 after 500 [namespace code { 1036 lappend x timeout 1037 }] 1038 chan event $f readable [namespace code { 1039 lappend x [chan gets $f] 1040 }] 1041 vwait [namespace which -variable x] 1042 vwait [namespace which -variable x] 1043 chan configure $f -blocking 1 1044 chan puts -nonewline $f "baz\n" 1045 after 500 [namespace code { 1046 lappend x timeout 1047 }] 1048 chan configure $f -blocking 0 1049 vwait [namespace which -variable x] 1050 vwait [namespace which -variable x] 1051 return $x 1052} -cleanup { 1053 chan close $f 1054} -result {{} timeout foobarbaz timeout} 1055 1056test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} -body { 1057 # (result == TCL_CONVERT_MULTIBYTE) 1058 set f [open $path(test1) w] 1059 chan configure $f -encoding shiftjis 1060 chan puts $f "123456789012301234\nend" 1061 chan close $f 1062 set f [open $path(test1)] 1063 chan configure $f -encoding shiftjis -buffersize 16 1064 chan gets $f 1065} -cleanup { 1066 chan close $f 1067} -result "123456789012301234" 1068test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body { 1069 # (bufPtr->nextAdded < bufPtr->bufLength) 1070 set f [open $path(test1) w] 1071 chan configure $f -encoding binary 1072 chan puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82" 1073 chan close $f 1074 set f [open $path(test1)] 1075 chan configure $f -encoding shiftjis 1076 list [chan gets $f line] $line [chan eof $f] 1077} -cleanup { 1078 chan close $f 1079} -result {10 1234567890 0} 1080test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { 1081 set x "" 1082} -constraints {testchannel} -body { 1083 set f [open $path(test1) w] 1084 chan configure $f -encoding binary 1085 chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" 1086 chan close $f 1087 set f [open $path(test1)] 1088 chan configure $f -encoding shiftjis 1089 lappend x [chan gets $f line] $line 1090 lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f] 1091 lappend x [chan gets $f line] $line 1092} -cleanup { 1093 chan close $f 1094} -result [list 15 "123456789012301" 18 0 1 -1 ""] 1095test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { 1096 variable x "" 1097} -constraints {stdio fileevent} -body { 1098 set f [openpipe w+ $path(cat)] 1099 chan configure $f -encoding binary -buffering none 1100 chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" 1101 chan configure $f -encoding shiftjis -blocking 0 1102 chan event $f read [namespace code { 1103 lappend x [chan gets $f line] $line [chan blocked $f] 1104 }] 1105 vwait [namespace which -variable x] 1106 chan configure $f -encoding binary -blocking 1 1107 chan puts $f "\x51\x82\x52" 1108 chan configure $f -encoding shiftjis 1109 vwait [namespace which -variable x] 1110 return $x 1111} -cleanup { 1112 chan close $f 1113} -result [list -1 "" 1 17 "12345678901230123" 0] 1114 1115test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constraints {testchannel} -body { 1116 # (bufPtr->nextPtr == NULL) 1117 set f [open $path(test1) w] 1118 chan configure $f -encoding ascii -translation lf 1119 chan puts -nonewline $f "123456789012345\r\n2345678" 1120 chan close $f 1121 set f [open $path(test1)] 1122 chan configure $f -encoding ascii -translation auto -buffersize 16 1123 # here 1124 chan gets $f 1125 testchannel inputbuffered $f 1126} -cleanup { 1127 chan close $f 1128} -result 7 1129test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { 1130 variable x {} 1131} -constraints {stdio testchannel fileevent} -body { 1132 # not (bufPtr->nextPtr == NULL) 1133 set f [openpipe w+ $path(cat)] 1134 chan configure $f -translation lf -encoding ascii -buffering none 1135 chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" 1136 chan event $f read [namespace code { 1137 lappend x [chan gets $f line] $line [testchannel inputbuffered $f] 1138 }] 1139 chan configure $f -encoding utf-16 -buffersize 16 -blocking 0 1140 vwait [namespace which -variable x] 1141 chan configure $f -translation auto -encoding ascii -blocking 1 1142 # here 1143 vwait [namespace which -variable x] 1144 return $x 1145} -cleanup { 1146 chan close $f 1147} -result {-1 {} 42 15 123456789012345 25} 1148test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel fileevent} -body { 1149 # (bytesLeft == 0) 1150 set f [openpipe w+ $path(cat)] 1151 chan configure $f -translation {auto binary} 1152 chan puts -nonewline $f "abcdefghijklmno\r" 1153 chan flush $f 1154 list [chan gets $f line] $line [testchannel queuedcr $f] 1155} -cleanup { 1156 chan close $f 1157} -result {15 abcdefghijklmno 1} 1158set a "123456789012345678901234567890" 1159append a "123456789012345678901234567890" 1160append a "1234567890123456789012345678901" 1161test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body { 1162 # not (bytesLeft == 0) 1163 set f [open $path(test1) w+] 1164 chan configure $f -translation binary 1165 chan puts $f "${a}\r\nabcdef" 1166 chan close $f 1167 set f [open $path(test1)] 1168 chan configure $f -encoding binary -translation auto 1169 # "${a}\r" was converted in one operation (because ENCODING_LINESIZE is 1170 # 30). To check if "\n" follows, calls PeekAhead and determines that 1171 # cached data is available in buffer w/o having to call driver. 1172 chan gets $f 1173} -cleanup { 1174 chan close $f 1175} -result $a 1176unset a 1177test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel fileevent} -body { 1178 # (bufPtr->nextAdded < bufPtr->length) 1179 set f [openpipe w+ $path(cat)] 1180 chan configure $f -translation {auto binary} 1181 chan puts -nonewline $f "abcdefghijklmno\r" 1182 chan flush $f 1183 # here 1184 list [chan gets $f line] $line [testchannel queuedcr $f] 1185} -cleanup { 1186 chan close $f 1187} -result {15 abcdefghijklmno 1} 1188test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel fileevent} -body { 1189 # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) 1190 set f [openpipe w+ $path(cat)] 1191 chan configure $f -translation {auto binary} -buffersize 16 1192 chan puts -nonewline $f "abcdefghijklmno\r" 1193 chan flush $f 1194 # here 1195 list [chan gets $f line] $line [testchannel queuedcr $f] 1196} -cleanup { 1197 chan close $f 1198} -result {15 abcdefghijklmno 1} 1199test chan-io-8.7 {PeekAhead: cleanup} -setup { 1200 set x "" 1201} -constraints {stdio testchannel fileevent} -body { 1202 # Make sure bytes are removed from buffer. 1203 set f [openpipe w+ $path(cat)] 1204 chan configure $f -translation {auto binary} -buffering none 1205 chan puts -nonewline $f "abcdefghijklmno\r" 1206 # here 1207 lappend x [chan gets $f line] $line [testchannel queuedcr $f] 1208 chan puts -nonewline $f "\x1A" 1209 lappend x [chan gets $f line] $line 1210} -cleanup { 1211 chan close $f 1212} -result {15 abcdefghijklmno 1 -1 {}} 1213 1214test chan-io-9.1 {CommonGetsCleanup} emptyTest { 1215} {} 1216 1217test chan-io-10.1 {Tcl_ReadChars: CheckChannelErrors} emptyTest { 1218 # no test, need to cause an async error. 1219} {} 1220test chan-io-10.2 {Tcl_ReadChars: loop until enough copied} -body { 1221 # one time 1222 # for (copied = 0; (unsigned) toRead > 0; ) 1223 set f [open $path(test1) w] 1224 chan puts $f abcdefghijklmnop 1225 chan close $f 1226 set f [open $path(test1)] 1227 chan read $f 5 1228} -cleanup { 1229 chan close $f 1230} -result {abcde} 1231test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} -body { 1232 # multiple times 1233 # for (copied = 0; (unsigned) toRead > 0; ) 1234 set f [open $path(test1) w] 1235 chan puts $f abcdefghijklmnopqrstuvwxyz 1236 chan close $f 1237 set f [open $path(test1)] 1238 chan configure $f -buffersize 16 1239 # here 1240 chan read $f 19 1241} -cleanup { 1242 chan close $f 1243} -result {abcdefghijklmnopqrs} 1244test chan-io-10.4 {Tcl_ReadChars: no more in channel buffer} -body { 1245 # (copiedNow < 0) 1246 set f [open $path(test1) w] 1247 chan puts -nonewline $f abcdefghijkl 1248 chan close $f 1249 set f [open $path(test1)] 1250 # here 1251 chan read $f 1000 1252} -cleanup { 1253 chan close $f 1254} -result {abcdefghijkl} 1255test chan-io-10.5 {Tcl_ReadChars: stop on EOF} -body { 1256 # (chanPtr->flags & CHANNEL_EOF) 1257 set f [open $path(test1) w] 1258 chan puts -nonewline $f abcdefghijkl 1259 chan close $f 1260 set f [open $path(test1)] 1261 # here 1262 chan read $f 1000 1263} -cleanup { 1264 chan close $f 1265} -result {abcdefghijkl} 1266 1267test chan-io-11.1 {ReadBytes: want to read a lot} -body { 1268 # ((unsigned) toRead > (unsigned) srcLen) 1269 set f [open $path(test1) w] 1270 chan puts -nonewline $f abcdefghijkl 1271 chan close $f 1272 set f [open $path(test1)] 1273 chan configure $f -encoding binary 1274 # here 1275 chan read $f 1000 1276} -cleanup { 1277 chan close $f 1278} -result {abcdefghijkl} 1279test chan-io-11.2 {ReadBytes: want to read all} -body { 1280 # ((unsigned) toRead > (unsigned) srcLen) 1281 set f [open $path(test1) w] 1282 chan puts -nonewline $f abcdefghijkl 1283 chan close $f 1284 set f [open $path(test1)] 1285 chan configure $f -encoding binary 1286 # here 1287 chan read $f 1288} -cleanup { 1289 chan close $f 1290} -result {abcdefghijkl} 1291test chan-io-11.3 {ReadBytes: allocate more space} -body { 1292 # (toRead > length - offset - 1) 1293 set f [open $path(test1) w] 1294 chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz 1295 chan close $f 1296 set f [open $path(test1)] 1297 chan configure $f -buffersize 16 -encoding binary 1298 # here 1299 chan read $f 1300} -cleanup { 1301 chan close $f 1302} -result {abcdefghijklmnopqrstuvwxyz} 1303test chan-io-11.4 {ReadBytes: EOF char found} -body { 1304 # (TranslateInputEOL() != 0) 1305 set f [open $path(test1) w] 1306 chan puts $f abcdefghijklmnopqrstuvwxyz 1307 chan close $f 1308 set f [open $path(test1)] 1309 chan configure $f -eofchar m -encoding binary 1310 # here 1311 list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f] 1312} -cleanup { 1313 chan close $f 1314} -result {abcdefghijkl 1 {} 1} 1315 1316test chan-io-12.1 {ReadChars: want to read a lot} -body { 1317 # ((unsigned) toRead > (unsigned) srcLen) 1318 set f [open $path(test1) w] 1319 chan puts -nonewline $f abcdefghijkl 1320 chan close $f 1321 set f [open $path(test1)] 1322 # here 1323 chan read $f 1000 1324} -cleanup { 1325 chan close $f 1326} -result {abcdefghijkl} 1327test chan-io-12.2 {ReadChars: want to read all} -body { 1328 # ((unsigned) toRead > (unsigned) srcLen) 1329 set f [open $path(test1) w] 1330 chan puts -nonewline $f abcdefghijkl 1331 chan close $f 1332 set f [open $path(test1)] 1333 # here 1334 chan read $f 1335} -cleanup { 1336 chan close $f 1337} -result {abcdefghijkl} 1338test chan-io-12.3 {ReadChars: allocate more space} -body { 1339 # (toRead > length - offset - 1) 1340 set f [open $path(test1) w] 1341 chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz 1342 chan close $f 1343 set f [open $path(test1)] 1344 chan configure $f -buffersize 16 1345 # here 1346 chan read $f 1347} -cleanup { 1348 chan close $f 1349} -result {abcdefghijklmnopqrstuvwxyz} 1350test chan-io-12.4 {ReadChars: split-up char} -setup { 1351 variable x {} 1352} -constraints {stdio testchannel fileevent} -body { 1353 # (srcRead == 0) 1354 set f [openpipe w+ $path(cat)] 1355 chan configure $f -encoding binary -buffering none -buffersize 16 1356 chan puts -nonewline $f "123456789012345\x96" 1357 chan configure $f -encoding shiftjis -blocking 0 1358 chan event $f read [namespace code { 1359 lappend x [chan read $f] [testchannel inputbuffered $f] 1360 }] 1361 chan configure $f -encoding shiftjis 1362 vwait [namespace which -variable x] 1363 chan configure $f -encoding binary -blocking 1 1364 chan puts -nonewline $f "\x7B" 1365 after 500 ;# Give the cat process time to catch up 1366 chan configure $f -encoding shiftjis -blocking 0 1367 vwait [namespace which -variable x] 1368 return $x 1369} -cleanup { 1370 chan close $f 1371} -result [list "123456789012345" 1 "本" 0] 1372test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { 1373 variable x {} 1374} -constraints {stdio fileevent} -body { 1375 set path(test1) [makeFile { 1376 chan configure stdout -encoding binary -buffering none 1377 chan gets stdin; chan puts -nonewline "\xE7" 1378 chan gets stdin; chan puts -nonewline "\x89" 1379 chan gets stdin; chan puts -nonewline "\xA6" 1380 } test1] 1381 set f [openpipe r+ $path(test1)] 1382 chan event $f readable [namespace code { 1383 lappend x [chan read $f] 1384 if {[chan eof $f]} { 1385 lappend x eof 1386 } 1387 }] 1388 chan puts $f "go1" 1389 chan flush $f 1390 chan configure $f -blocking 0 -encoding utf-8 1391 vwait [namespace which -variable x] 1392 after 500 [namespace code { lappend x timeout }] 1393 vwait [namespace which -variable x] 1394 chan puts $f "go2" 1395 chan flush $f 1396 vwait [namespace which -variable x] 1397 after 500 [namespace code { lappend x timeout }] 1398 vwait [namespace which -variable x] 1399 chan puts $f "go3" 1400 chan flush $f 1401 vwait [namespace which -variable x] 1402 vwait [namespace which -variable x] 1403 lappend x [catch {chan close $f} msg] $msg 1404} -result "{} timeout {} timeout 牦 {} eof 0 {}" 1405 1406test chan-io-13.1 {TranslateInputEOL: cr mode} -body { 1407 set f [open $path(test1) w] 1408 chan configure $f -translation lf 1409 chan puts -nonewline $f "abcd\rdef\r" 1410 chan close $f 1411 set f [open $path(test1)] 1412 chan configure $f -translation cr 1413 chan read $f 1414} -cleanup { 1415 chan close $f 1416} -result "abcd\ndef\n" 1417test chan-io-13.2 {TranslateInputEOL: crlf mode} -body { 1418 set f [open $path(test1) w] 1419 chan configure $f -translation lf 1420 chan puts -nonewline $f "abcd\r\ndef\r\n" 1421 chan close $f 1422 set f [open $path(test1)] 1423 chan configure $f -translation crlf 1424 chan read $f 1425} -cleanup { 1426 chan close $f 1427} -result "abcd\ndef\n" 1428test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body { 1429 # (src >= srcMax) 1430 set f [open $path(test1) w] 1431 chan configure $f -translation lf 1432 chan puts -nonewline $f "abcd\r\ndef\r" 1433 chan close $f 1434 set f [open $path(test1)] 1435 chan configure $f -translation crlf 1436 chan read $f 1437} -cleanup { 1438 chan close $f 1439} -result "abcd\ndef\r" 1440test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body { 1441 # (src >= srcMax) 1442 set f [open $path(test1) w] 1443 chan configure $f -translation lf 1444 chan puts -nonewline $f "abcd\r\ndef\rfgh" 1445 chan close $f 1446 set f [open $path(test1)] 1447 chan configure $f -translation crlf 1448 chan read $f 1449} -cleanup { 1450 chan close $f 1451} -result "abcd\ndef\rfgh" 1452test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body { 1453 # (src >= srcMax) 1454 set f [open $path(test1) w] 1455 chan configure $f -translation lf 1456 chan puts -nonewline $f "abcd\r\ndef\nfgh" 1457 chan close $f 1458 set f [open $path(test1)] 1459 chan configure $f -translation crlf 1460 chan read $f 1461} -cleanup { 1462 chan close $f 1463} -result "abcd\ndef\nfgh" 1464test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup { 1465 variable x {} 1466 variable y {} 1467} -constraints {stdio testchannel fileevent} -body { 1468 # (chanPtr->flags & INPUT_SAW_CR) 1469 # This test may fail on slower machines. 1470 set f [openpipe w+ $path(cat)] 1471 chan configure $f -blocking 0 -buffering none -translation {auto lf} 1472 chan event $f read [namespace code { 1473 lappend x [chan read $f] [testchannel queuedcr $f] 1474 }] 1475 chan puts -nonewline $f "abcdefghj\r" 1476 after 500 [namespace code {set y ok}] 1477 vwait [namespace which -variable y] 1478 chan puts -nonewline $f "\n01234" 1479 after 500 [namespace code {set y ok}] 1480 vwait [namespace which -variable y] 1481 return $x 1482} -cleanup { 1483 chan close $f 1484} -result [list "abcdefghj\n" 1 "01234" 0] 1485test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints testchannel -body { 1486 # (src >= srcMax) 1487 set f [open $path(test1) w] 1488 chan configure $f -translation lf 1489 chan puts -nonewline $f "abcd\r" 1490 chan close $f 1491 set f [open $path(test1)] 1492 chan configure $f -translation auto 1493 list [chan read $f] [testchannel queuedcr $f] 1494} -cleanup { 1495 chan close $f 1496} -result [list "abcd\n" 1] 1497test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} -body { 1498 # (*src == '\n') 1499 set f [open $path(test1) w] 1500 chan configure $f -translation lf 1501 chan puts -nonewline $f "abcd\r\ndef" 1502 chan close $f 1503 set f [open $path(test1)] 1504 chan configure $f -translation auto 1505 chan read $f 1506} -cleanup { 1507 chan close $f 1508} -result "abcd\ndef" 1509test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} -body { 1510 set f [open $path(test1) w] 1511 chan configure $f -translation lf 1512 chan puts -nonewline $f "abcd\rdef" 1513 chan close $f 1514 set f [open $path(test1)] 1515 chan configure $f -translation auto 1516 chan read $f 1517} -cleanup { 1518 chan close $f 1519} -result "abcd\ndef" 1520test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body { 1521 # not (*src == '\r') 1522 set f [open $path(test1) w] 1523 chan configure $f -translation lf 1524 chan puts -nonewline $f "abcd\ndef" 1525 chan close $f 1526 set f [open $path(test1)] 1527 chan configure $f -translation auto 1528 chan read $f 1529} -cleanup { 1530 chan close $f 1531} -result "abcd\ndef" 1532test chan-io-13.11 {TranslateInputEOL: EOF char} -body { 1533 # (*chanPtr->inEofChar != '\x00') 1534 set f [open $path(test1) w] 1535 chan configure $f -translation lf 1536 chan puts -nonewline $f "abcd\ndefgh" 1537 chan close $f 1538 set f [open $path(test1)] 1539 chan configure $f -translation auto -eofchar e 1540 chan read $f 1541} -cleanup { 1542 chan close $f 1543} -result "abcd\nd" 1544test chan-io-13.12 {TranslateInputEOL: find EOF char in src} -body { 1545 # (*chanPtr->inEofChar != '\x00') 1546 set f [open $path(test1) w] 1547 chan configure $f -translation lf 1548 chan puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n" 1549 chan close $f 1550 set f [open $path(test1)] 1551 chan configure $f -translation auto -eofchar e 1552 chan read $f 1553} -cleanup { 1554 chan close $f 1555} -result "\n\n\nab\n\nd" 1556 1557# Test standard handle management. The functions tested are Tcl_SetStdChannel 1558# and Tcl_GetStdChannel. Incidentally we are also testing channel table 1559# management. 1560 1561if {[testConstraint testchannel]} { 1562 set consoleFileNames [lsort [testchannel open]] 1563} else { 1564 # just to avoid an error 1565 set consoleFileNames [list] 1566} 1567 1568test chan-io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} { 1569 set result "" 1570 lappend result [chan configure stdin -buffering] 1571 lappend result [chan configure stdout -buffering] 1572 lappend result [chan configure stderr -buffering] 1573 lappend result [lsort [testchannel open]] 1574} [list line line none $consoleFileNames] 1575test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup { 1576 interp create x 1577 set result "" 1578} -body { 1579 lappend result [x eval {chan configure stdin -buffering}] 1580 lappend result [x eval {chan configure stdout -buffering}] 1581 lappend result [x eval {chan configure stderr -buffering}] 1582} -cleanup { 1583 interp delete x 1584} -result {line line none} 1585set path(test3) [makeFile {} test3] 1586test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints exec -body { 1587 set f [open $path(test1) w] 1588 chan puts -nonewline $f { 1589 chan close stdin 1590 chan close stdout 1591 chan close stderr 1592 set f [} 1593 chan puts $f [list open $path(test1) r]] 1594 chan puts $f "set f2 \[[list open $path(test2) w]]" 1595 chan puts $f "set f3 \[[list open $path(test3) w]]" 1596 chan puts $f { chan puts stdout [chan gets stdin] 1597 chan puts stdout out 1598 chan puts stderr err 1599 chan close $f 1600 chan close $f2 1601 chan close $f3 1602 } 1603 chan close $f 1604 set result [exec [interpreter] $path(test1)] 1605 set f [open $path(test2) r] 1606 set f2 [open $path(test3) r] 1607 lappend result [chan read $f] [chan read $f2] 1608} -cleanup { 1609 chan close $f 1610 chan close $f2 1611} -result {{ 1612out 1613} {err 1614}} 1615# This test relies on the fact that stdout is used before stderr. 1616test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec} -body { 1617 set f [open $path(test1) w] 1618 chan puts -nonewline $f { chan close stdin 1619 chan close stdout 1620 chan close stderr 1621 set f [} 1622 chan puts $f [list open $path(test1) r]] 1623 chan puts $f "set f2 \[[list open $path(test2) w]]" 1624 chan puts $f "set f3 \[[list open $path(test3) w]]" 1625 chan puts $f { 1626 chan puts stdout [chan gets stdin] 1627 chan puts stdout $f2 1628 chan puts stderr $f3 1629 chan close $f 1630 chan close $f2 1631 chan close $f3 1632 } 1633 chan close $f 1634 set result [exec [interpreter] $path(test1)] 1635 set f [open $path(test2) r] 1636 set f2 [open $path(test3) r] 1637 lappend result [chan read $f] [chan read $f2] 1638} -cleanup { 1639 chan close $f 1640 chan close $f2 1641} -result {{ chan close stdin 1642stdout 1643} {stderr 1644}} 1645catch {interp delete z} 1646test chan-io-14.5 {Tcl_GetChannel: stdio name translation} -setup { 1647 interp create z 1648} -body { 1649 chan eof stdin 1650 catch {z eval chan flush stdin} msg1 1651 catch {z eval chan close stdin} msg2 1652 catch {z eval chan flush stdin} msg3 1653 list $msg1 $msg2 $msg3 1654} -cleanup { 1655 interp delete z 1656} -result {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}} 1657test chan-io-14.6 {Tcl_GetChannel: stdio name translation} -setup { 1658 interp create z 1659} -body { 1660 chan eof stdout 1661 catch {z eval chan flush stdout} msg1 1662 catch {z eval chan close stdout} msg2 1663 catch {z eval chan flush stdout} msg3 1664 list $msg1 $msg2 $msg3 1665} -cleanup { 1666 interp delete z 1667} -result {{} {} {can not find channel named "stdout"}} 1668test chan-io-14.7 {Tcl_GetChannel: stdio name translation} -setup { 1669 interp create z 1670} -body { 1671 chan eof stderr 1672 catch {z eval chan flush stderr} msg1 1673 catch {z eval chan close stderr} msg2 1674 catch {z eval chan flush stderr} msg3 1675 list $msg1 $msg2 $msg3 1676} -cleanup { 1677 interp delete z 1678} -result {{} {} {can not find channel named "stderr"}} 1679set path(script) [makeFile {} script] 1680test chan-io-14.8 {reuse of stdio special channels} -setup { 1681 file delete $path(script) 1682 file delete $path(test1) 1683} -constraints stdio -body { 1684 set f [open $path(script) w] 1685 chan puts -nonewline $f { 1686 chan close stderr 1687 set f [} 1688 chan puts $f [list open $path(test1) w]] 1689 chan puts -nonewline $f { 1690 chan puts stderr hello 1691 chan close $f 1692 set f [} 1693 chan puts $f [list open $path(test1) r]] 1694 chan puts $f { 1695 chan puts [chan gets $f] 1696 } 1697 chan close $f 1698 set f [openpipe r $path(script)] 1699 chan gets $f 1700} -cleanup { 1701 chan close $f 1702} -result hello 1703test chan-io-14.9 {reuse of stdio special channels} -setup { 1704 file delete $path(script) 1705 file delete $path(test1) 1706} -constraints {stdio fileevent} -body { 1707 set f [open $path(script) w] 1708 chan puts $f { 1709 array set path [lindex $argv 0] 1710 set f [open $path(test1) w] 1711 chan puts $f hello 1712 chan close $f 1713 chan close stderr 1714 set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r] 1715 chan puts [chan gets $f] 1716 } 1717 chan close $f 1718 set f [openpipe r $path(script) [array get path]] 1719 chan gets $f 1720} -cleanup { 1721 chan close $f 1722 # Added delay to give Windows time to stop the spawned process and clean 1723 # up its grip on the file test1. Added delete as proper test cleanup. 1724 # The failing tests were 18.1 and 18.2 as first re-users of file "test1". 1725 after [expr {[testConstraint win] ? 10000 : 500}] 1726 file delete $path(script) 1727 file delete $path(test1) 1728} -result hello 1729 1730test chan-io-15.1 {Tcl_CreateChan CloseHandler} emptyTest { 1731} {} 1732 1733test chan-io-16.1 {Tcl_DeleteChan CloseHandler} emptyTest { 1734} {} 1735 1736# Test channel table management. The functions tested are GetChannelTable, 1737# DeleteChannelTable, Tcl_RegisterChannel, Tcl_UnregisterChannel, 1738# Tcl_GetChannel and Tcl_CreateChannel. 1739# 1740# These functions use "eof stdin" to ensure that the standard channels are 1741# added to the channel table of the interpreter. 1742 1743test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} -setup { 1744 set l "" 1745} -constraints {testchannel} -body { 1746 set l1 [testchannel refcount stdin] 1747 chan eof stdin 1748 interp create x 1749 lappend l [expr {[testchannel refcount stdin] - $l1}] 1750 x eval {chan eof stdin} 1751 lappend l [expr {[testchannel refcount stdin] - $l1}] 1752 interp delete x 1753 lappend l [expr {[testchannel refcount stdin] - $l1}] 1754} -result {0 1 0} 1755test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} -setup { 1756 set l "" 1757} -constraints {testchannel} -body { 1758 set l1 [testchannel refcount stdout] 1759 chan eof stdin 1760 interp create x 1761 lappend l [expr {[testchannel refcount stdout] - $l1}] 1762 x eval {chan eof stdout} 1763 lappend l [expr {[testchannel refcount stdout] - $l1}] 1764 interp delete x 1765 lappend l [expr {[testchannel refcount stdout] - $l1}] 1766} -result {0 1 0} 1767test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} -setup { 1768 set l "" 1769} -constraints {testchannel} -body { 1770 set l1 [testchannel refcount stderr] 1771 chan eof stdin 1772 interp create x 1773 lappend l [expr {[testchannel refcount stderr] - $l1}] 1774 x eval {chan eof stderr} 1775 lappend l [expr {[testchannel refcount stderr] - $l1}] 1776 interp delete x 1777 lappend l [expr {[testchannel refcount stderr] - $l1}] 1778} -result {0 1 0} 1779 1780test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { 1781 file delete -force $path(test1) 1782 set l "" 1783} -constraints {testchannel} -body { 1784 set f [open $path(test1) w] 1785 lappend l [lindex [testchannel info $f] 15] 1786 chan close $f 1787 if {[catch {lindex [testchannel info $f] 15} msg]} { 1788 lappend l $msg 1789 } else { 1790 lappend l "very broken: $f found after being chan closed" 1791 } 1792 string equal $l [list 1 "can not find channel named \"$f\""] 1793} -result 1 1794test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { 1795 file delete -force $path(test1) 1796 set l "" 1797} -constraints {testchannel} -body { 1798 set f [open $path(test1) w] 1799 lappend l [lindex [testchannel info $f] 15] 1800 interp create x 1801 interp share "" $f x 1802 lappend l [lindex [testchannel info $f] 15] 1803 x eval chan close $f 1804 lappend l [lindex [testchannel info $f] 15] 1805 interp delete x 1806 lappend l [lindex [testchannel info $f] 15] 1807 chan close $f 1808 if {[catch {lindex [testchannel info $f] 15} msg]} { 1809 lappend l $msg 1810 } else { 1811 lappend l "very broken: $f found after being chan closed" 1812 } 1813 string equal $l [list 1 2 1 1 "can not find channel named \"$f\""] 1814} -result 1 1815test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { 1816 file delete $path(test1) 1817 set l "" 1818} -constraints {testchannel} -body { 1819 set f [open $path(test1) w] 1820 lappend l [lindex [testchannel info $f] 15] 1821 interp create x 1822 interp share "" $f x 1823 lappend l [lindex [testchannel info $f] 15] 1824 interp delete x 1825 lappend l [lindex [testchannel info $f] 15] 1826 chan close $f 1827 if {[catch {lindex [testchannel info $f] 15} msg]} { 1828 lappend l $msg 1829 } else { 1830 lappend l "very broken: $f found after being chan closed" 1831 } 1832 string equal $l [list 1 2 1 "can not find channel named \"$f\""] 1833} -result 1 1834 1835test chan-io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { 1836 chan eof stdin 1837} 0 1838test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} -setup { 1839 file delete $path(test1) 1840} -body { 1841 set f [open $path(test1) w] 1842 chan eof $f 1843} -cleanup { 1844 chan close $f 1845} -result 0 1846test chan-io-19.3 {Tcl_GetChannel, channel not found} -body { 1847 chan eof file34 1848} -returnCodes error -result {can not find channel named "file34"} 1849test chan-io-19.4 {Tcl_CreateChannel, insertion into channel table} -setup { 1850 file delete $path(test1) 1851 set l "" 1852} -constraints {testchannel} -body { 1853 set f [open $path(test1) w] 1854 lappend l [chan eof $f] 1855 chan close $f 1856 if {[catch {lindex [testchannel info $f] 15} msg]} { 1857 lappend l $msg 1858 } else { 1859 lappend l "very broken: $f found after being chan closed" 1860 } 1861 string equal $l [list 0 "can not find channel named \"$f\""] 1862} -result 1 1863 1864test chan-io-20.1 {Tcl_CreateChannel: initial settings} -setup { 1865 set old [encoding system] 1866} -body { 1867 set a [open $path(test2) w] 1868 encoding system ascii 1869 set f [open $path(test1) w] 1870 chan configure $f -encoding 1871} -cleanup { 1872 encoding system $old 1873 chan close $f 1874 chan close $a 1875} -result {ascii} 1876test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body { 1877 set f [open $path(test1) w+] 1878 list [chan configure $f -eofchar] [chan configure $f -translation] 1879} -cleanup { 1880 chan close $f 1881} -result [list [list \x1A ""] {auto crlf}] 1882test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body { 1883 set f [open $path(test1) w+] 1884 list [chan configure $f -eofchar] [chan configure $f -translation] 1885} -cleanup { 1886 chan close $f 1887} -result {{{} {}} {auto lf}} 1888test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { 1889 set path(stdout) [makeFile {} stdout] 1890} -constraints {stdio notWinCI} -body { 1891 set f [open $path(script) w] 1892 chan puts -nonewline $f { 1893 chan close stdout 1894 set f1 [} 1895 chan puts $f [list open $path(stdout) w]] 1896 chan puts $f { 1897 chan configure $f1 -buffersize 777 1898 chan puts stderr [chan configure stdout -buffersize] 1899 } 1900 chan close $f 1901 set f [openpipe r $path(script)] 1902 chan close $f 1903} -cleanup { 1904 removeFile $path(stdout) 1905} -returnCodes error -result {777} 1906 1907test chan-io-21.1 {Chan CloseChannelsOnExit} emptyTest { 1908} {} 1909 1910# Test management of attributes associated with a channel, such as its default 1911# translation, its name and type, etc. The functions tested in this group are 1912# Tcl_GetChannelName, Tcl_GetChannelType and Tcl_GetChannelFile. 1913# Tcl_GetChannelInstanceData not tested because files do not use the instance 1914# data. 1915 1916test chan-io-22.1 {Tcl_GetChannelMode} emptyTest { 1917 # Not used anywhere in Tcl. 1918} {} 1919 1920test chan-io-23.1 {Tcl_GetChannelName} -constraints {testchannel} -setup { 1921 file delete $path(test1) 1922} -body { 1923 set f [open $path(test1) w] 1924 set n [testchannel name $f] 1925 expr {$n eq $f ? "ok" : "$n != $f"} 1926} -cleanup { 1927 chan close $f 1928} -result ok 1929 1930test chan-io-24.1 {Tcl_GetChannelType} -constraints {testchannel} -setup { 1931 file delete $path(test1) 1932} -body { 1933 set f [open $path(test1) w] 1934 testchannel type $f 1935} -cleanup { 1936 chan close $f 1937} -result "file" 1938 1939test chan-io-25.1 {Tcl_GetChannelHandle, input} -setup { 1940 set l "" 1941} -constraints {testchannel} -body { 1942 set f [open $path(test1) w] 1943 chan configure $f -translation lf -eofchar {} 1944 chan puts $f "1234567890\n098765432" 1945 chan close $f 1946 set f [open $path(test1) r] 1947 chan gets $f 1948 lappend l [testchannel inputbuffered $f] 1949 lappend l [chan tell $f] 1950} -cleanup { 1951 chan close $f 1952} -result {10 11} 1953test chan-io-25.2 {Tcl_GetChannelHandle, output} -setup { 1954 file delete $path(test1) 1955 set l "" 1956} -constraints {testchannel} -body { 1957 set f [open $path(test1) w] 1958 chan configure $f -translation lf 1959 chan puts $f hello 1960 lappend l [testchannel outputbuffered $f] 1961 lappend l [chan tell $f] 1962 chan flush $f 1963 lappend l [testchannel outputbuffered $f] 1964 lappend l [chan tell $f] 1965} -cleanup { 1966 chan close $f 1967 file delete $path(test1) 1968} -result {6 6 0 6} 1969 1970test chan-io-26.1 {Tcl_GetChannelInstanceData} -body { 1971 # "pid" command uses Tcl_GetChannelInstanceData 1972 # Don't care what pid is (but must be a number), just want to exercise it. 1973 set f [openpipe r << exit] 1974 pid $f 1975} -constraints stdio -cleanup { 1976 chan close $f 1977} -match regexp -result {^\d+$} 1978 1979# Test flushing. The functions tested here are FlushChannel. 1980 1981test chan-io-27.1 {FlushChannel, no output buffered} -setup { 1982 file delete $path(test1) 1983} -body { 1984 set f [open $path(test1) w] 1985 chan flush $f 1986 file size $path(test1) 1987} -cleanup { 1988 chan close $f 1989} -result 0 1990test chan-io-27.2 {FlushChannel, some output buffered} -setup { 1991 file delete $path(test1) 1992 set l "" 1993} -body { 1994 set f [open $path(test1) w] 1995 chan configure $f -translation lf -eofchar {} 1996 chan puts $f hello 1997 lappend l [file size $path(test1)] 1998 chan flush $f 1999 lappend l [file size $path(test1)] 2000 chan close $f 2001 lappend l [file size $path(test1)] 2002} -result {0 6 6} 2003test chan-io-27.3 {FlushChannel, implicit flush on chan close} -setup { 2004 file delete $path(test1) 2005 set l "" 2006} -body { 2007 set f [open $path(test1) w] 2008 chan configure $f -translation lf -eofchar {} 2009 chan puts $f hello 2010 lappend l [file size $path(test1)] 2011 chan close $f 2012 lappend l [file size $path(test1)] 2013} -result {0 6} 2014test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup { 2015 file delete $path(test1) 2016 set l "" 2017} -body { 2018 set f [open $path(test1) w] 2019 chan configure $f -translation lf -eofchar {} 2020 chan configure $f -buffersize 60 2021 lappend l [file size $path(test1)] 2022 for {set i 0} {$i < 12} {incr i} { 2023 chan puts $f hello 2024 } 2025 lappend l [file size $path(test1)] 2026 chan flush $f 2027 lappend l [file size $path(test1)] 2028} -cleanup { 2029 chan close $f 2030} -result {0 60 72} 2031test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup { 2032 file delete $path(test1) 2033 set l "" 2034} -constraints {unixOrWin} -body { 2035 set f [open $path(test1) w] 2036 chan configure $f -translation lf -buffersize 60 -eofchar {} 2037 lappend l [file size $path(test1)] 2038 for {set i 0} {$i < 12} {incr i} { 2039 chan puts $f hello 2040 } 2041 lappend l [file size $path(test1)] 2042 chan close $f 2043 lappend l [file size $path(test1)] 2044} -result {0 60 72} 2045set path(pipe) [makeFile {} pipe] 2046set path(output) [makeFile {} output] 2047test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { 2048 file delete $path(pipe) 2049 file delete $path(output) 2050} -constraints {stdio asyncPipeChan Close} -body { 2051 set f [open $path(pipe) w] 2052 chan puts $f "set f \[[list open $path(output) w]]" 2053 chan puts $f { 2054 chan configure $f -translation lf -buffering none -eofchar {} 2055 while {![chan eof stdin]} { 2056 after 20 2057 chan puts -nonewline $f [chan read stdin 1024] 2058 } 2059 chan close $f 2060 } 2061 chan close $f 2062 set x 01234567890123456789012345678901 2063 for {set i 0} {$i < 11} {incr i} { 2064 set x "$x$x" 2065 } 2066 set f [open $path(output) w] 2067 chan close $f 2068 set f [openpipe w $path(pipe)] 2069 chan configure $f -blocking off 2070 chan puts -nonewline $f $x 2071 chan close $f 2072 set counter 0 2073 while {([file size $path(output)] < 65536) && ($counter < 1000)} { 2074 after 20 [list incr [namespace which -variable counter]] 2075 vwait [namespace which -variable counter] 2076 } 2077 if {$counter == 1000} { 2078 set result "file size only [file size $path(output)]" 2079 } else { 2080 set result ok 2081 } 2082} -result ok 2083 2084# Tests closing a channel. The functions tested are Chan CloseChannel and 2085# Tcl_Chan Close. 2086 2087test chan-io-28.1 {Chan CloseChannel called when all references are dropped} -setup { 2088 file delete $path(test1) 2089 set l "" 2090} -constraints {testchannel} -body { 2091 set f [open $path(test1) w] 2092 interp create x 2093 interp share "" $f x 2094 lappend l [testchannel refcount $f] 2095 x eval chan close $f 2096 interp delete x 2097 lappend l [testchannel refcount $f] 2098} -cleanup { 2099 chan close $f 2100} -result {2 1} 2101test chan-io-28.2 {Chan CloseChannel called when all references are dropped} -setup { 2102 file delete $path(test1) 2103} -body { 2104 set f [open $path(test1) w] 2105 interp create x 2106 interp share "" $f x 2107 chan puts -nonewline $f abc 2108 chan close $f 2109 x eval chan puts $f def 2110 x eval chan close $f 2111 interp delete x 2112 set f [open $path(test1) r] 2113 chan gets $f 2114} -cleanup { 2115 chan close $f 2116} -result abcdef 2117test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup { 2118 file delete $path(pipe) 2119 file delete $path(output) 2120} -constraints {stdio asyncPipeChan Close nonPortable} -body { 2121 set f [open $path(pipe) w] 2122 chan puts $f { 2123 # Need to not have eof char appended on chan close, because the other 2124 # side of the pipe already chan closed, so that writing would cause an 2125 # error "invalid file". 2126 chan configure stdout -eofchar {} 2127 chan configure stderr -eofchar {} 2128 set f [open $path(output) w] 2129 chan configure $f -translation lf -buffering none 2130 for {set x 0} {$x < 20} {incr x} { 2131 after 20 2132 chan puts -nonewline $f [chan read stdin 1024] 2133 } 2134 chan close $f 2135 } 2136 chan close $f 2137 set x 01234567890123456789012345678901 2138 for {set i 0} {$i < 11} {incr i} { 2139 set x "$x$x" 2140 } 2141 set f [open $path(output) w] 2142 chan close $f 2143 set f [openpipe r+ $path(pipe)] 2144 chan configure $f -blocking off -eofchar {} 2145 chan puts -nonewline $f $x 2146 chan close $f 2147 set counter 0 2148 while {([file size $path(output)] < 20480) && ($counter < 1000)} { 2149 after 20 [list incr [namespace which -variable counter]] 2150 vwait [namespace which -variable counter] 2151 } 2152 if {$counter == 1000} { 2153 set result probably_broken 2154 } else { 2155 set result ok 2156 } 2157} -result ok 2158test chan-io-28.4 {Tcl_Chan Close} -constraints {testchannel} -setup { 2159 file delete $path(test1) 2160 set l "" 2161} -body { 2162 lappend l [lsort [testchannel open]] 2163 set f [open $path(test1) w] 2164 lappend l [lsort [testchannel open]] 2165 chan close $f 2166 lappend l [lsort [testchannel open]] 2167 set x [list $consoleFileNames \ 2168 [lsort [list {*}$consoleFileNames $f]] \ 2169 $consoleFileNames] 2170 expr {$l eq $x ? "ok" : "{$l} != {$x}"} 2171} -result ok 2172test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { 2173 file delete $path(script) 2174} -constraints {stdio unix testchannel} -body { 2175 set f [open $path(script) w] 2176 chan puts $f { 2177 chan close stdin 2178 chan puts [testchannel open] 2179 } 2180 chan close $f 2181 set f [openpipe r $path(script)] 2182 set l [chan gets $f] 2183 chan close $f 2184 lsort $l 2185} -result {file1 file2} 2186test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup { 2187 set cat [makeFile { 2188 fconfigure stdout -buffering line 2189 while {[gets stdin line] >= 0} {puts $line} 2190 puts DONE 2191 exit 0 2192 } cat.tcl] 2193 variable done 2194} -body { 2195 set ff [openpipe r+ $cat] 2196 puts $ff Hey 2197 close $ff w 2198 set timer [after 1000 [namespace code {set done Failed}]] 2199 set acc {} 2200 fileevent $ff readable [namespace code { 2201 if {[gets $ff line] < 0} { 2202 set done Succeeded 2203 } else { 2204 lappend acc $line 2205 } 2206 }] 2207 vwait [namespace which -variable done] 2208 after cancel $timer 2209 close $ff r 2210 list $done $acc 2211} -cleanup { 2212 removeFile cat.tcl 2213} -result {Succeeded {Hey DONE}} 2214test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { 2215 set echo [makeFile { 2216 proc accept {s args} {set ::sok $s} 2217 set s [socket -server accept 0] 2218 puts [lindex [fconfigure $s -sockname] 2] 2219 flush stdout 2220 vwait ::sok 2221 fconfigure $sok -buffering line 2222 while {[gets $sok line]>=0} {puts $sok $line} 2223 puts $sok DONE 2224 exit 0 2225 } echo.tcl] 2226 variable done 2227 unset -nocomplain done 2228 set done "" 2229 set timer "" 2230 set ff [openpipe r $echo] 2231 gets $ff port 2232} -body { 2233 set s [socket 127.0.0.1 $port] 2234 puts $s Hey 2235 close $s w 2236 set timer [after 1000 [namespace code {set done Failed}]] 2237 set acc {} 2238 fileevent $s readable [namespace code { 2239 if {[gets $s line]<0} { 2240 set done Succeeded 2241 } else { 2242 lappend acc $line 2243 } 2244 }] 2245 vwait [namespace which -variable done] 2246 list $done $acc 2247} -cleanup { 2248 catch {close $s} 2249 close $ff 2250 after cancel $timer 2251 removeFile echo.tcl 2252} -result {Succeeded {Hey DONE}} 2253 2254test chan-io-29.1 {Tcl_WriteChars, channel not writable} -body { 2255 chan puts stdin hello 2256} -returnCodes error -result {channel "stdin" wasn't opened for writing} 2257test chan-io-29.2 {Tcl_WriteChars, empty string} -setup { 2258 file delete $path(test1) 2259} -body { 2260 set f [open $path(test1) w] 2261 chan configure $f -eofchar {} 2262 chan puts -nonewline $f "" 2263 chan close $f 2264 file size $path(test1) 2265} -result 0 2266test chan-io-29.3 {Tcl_WriteChars, nonempty string} -setup { 2267 file delete $path(test1) 2268} -body { 2269 set f [open $path(test1) w] 2270 chan configure $f -eofchar {} 2271 chan puts -nonewline $f hello 2272 chan close $f 2273 file size $path(test1) 2274} -result 5 2275test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} -setup { 2276 file delete $path(test1) 2277 set l "" 2278} -constraints {testchannel} -body { 2279 set f [open $path(test1) w] 2280 chan configure $f -translation lf -buffering full -eofchar {} 2281 chan puts $f hello 2282 lappend l [testchannel outputbuffered $f] 2283 lappend l [file size $path(test1)] 2284 chan flush $f 2285 lappend l [testchannel outputbuffered $f] 2286 lappend l [file size $path(test1)] 2287} -cleanup { 2288 chan close $f 2289} -result {6 0 0 6} 2290test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} -setup { 2291 file delete $path(test1) 2292 set l "" 2293} -constraints {testchannel} -body { 2294 set f [open $path(test1) w] 2295 chan configure $f -translation lf -buffering line -eofchar {} 2296 chan puts -nonewline $f hello 2297 lappend l [testchannel outputbuffered $f] 2298 lappend l [file size $path(test1)] 2299 chan puts $f hello 2300 lappend l [testchannel outputbuffered $f] 2301 lappend l [file size $path(test1)] 2302} -cleanup { 2303 chan close $f 2304} -result {5 0 0 11} 2305test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} -setup { 2306 file delete $path(test1) 2307 set l "" 2308} -constraints {testchannel} -body { 2309 set f [open $path(test1) w] 2310 chan configure $f -translation lf -buffering none -eofchar {} 2311 chan puts -nonewline $f hello 2312 lappend l [testchannel outputbuffered $f] 2313 lappend l [file size $path(test1)] 2314 chan puts $f hello 2315 lappend l [testchannel outputbuffered $f] 2316 lappend l [file size $path(test1)] 2317} -cleanup { 2318 chan close $f 2319} -result {0 5 0 11} 2320test chan-io-29.7 {Tcl_Flush, full buffering} -setup { 2321 file delete $path(test1) 2322 set l "" 2323} -constraints {testchannel} -body { 2324 set f [open $path(test1) w] 2325 chan configure $f -translation lf -buffering full -eofchar {} 2326 chan puts -nonewline $f hello 2327 lappend l [testchannel outputbuffered $f] 2328 lappend l [file size $path(test1)] 2329 chan puts $f hello 2330 lappend l [testchannel outputbuffered $f] 2331 lappend l [file size $path(test1)] 2332 chan flush $f 2333 lappend l [testchannel outputbuffered $f] 2334 lappend l [file size $path(test1)] 2335} -cleanup { 2336 chan close $f 2337} -result {5 0 11 0 0 11} 2338test chan-io-29.8 {Tcl_Flush, full buffering} -setup { 2339 file delete $path(test1) 2340 set l "" 2341} -constraints {testchannel} -body { 2342 set f [open $path(test1) w] 2343 chan configure $f -translation lf -buffering line 2344 chan puts -nonewline $f hello 2345 lappend l [testchannel outputbuffered $f] 2346 lappend l [file size $path(test1)] 2347 chan flush $f 2348 lappend l [testchannel outputbuffered $f] 2349 lappend l [file size $path(test1)] 2350 chan puts $f hello 2351 lappend l [testchannel outputbuffered $f] 2352 lappend l [file size $path(test1)] 2353 chan flush $f 2354 lappend l [testchannel outputbuffered $f] 2355 lappend l [file size $path(test1)] 2356} -cleanup { 2357 chan close $f 2358} -result {5 0 0 5 0 11 0 11} 2359test chan-io-29.9 {Tcl_Flush, channel not writable} -body { 2360 chan flush stdin 2361} -returnCodes error -result {channel "stdin" wasn't opened for writing} 2362test chan-io-29.10 {Tcl_WriteChars, looping and buffering} -setup { 2363 file delete $path(test1) 2364} -body { 2365 set f1 [open $path(test1) w] 2366 chan configure $f1 -translation lf -eofchar {} 2367 set f2 [open $path(longfile) r] 2368 for {set x 0} {$x < 10} {incr x} { 2369 chan puts $f1 [chan gets $f2] 2370 } 2371 chan close $f2 2372 chan close $f1 2373 file size $path(test1) 2374} -result 387 2375test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup { 2376 file delete $path(test1) 2377} -body { 2378 set f1 [open $path(test1) w] 2379 chan configure $f1 -eofchar {} 2380 set f2 [open $path(longfile) r] 2381 for {set x 0} {$x < 10} {incr x} { 2382 chan puts -nonewline $f1 [chan gets $f2] 2383 } 2384 chan close $f1 2385 chan close $f2 2386 file size $path(test1) 2387} -result 377 2388test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { 2389 file delete $path(test1) 2390 file delete $path(pipe) 2391} -constraints stdio -body { 2392 set f1 [open $path(pipe) w] 2393 chan puts $f1 "set f1 \[[list open $path(longfile) r]]" 2394 chan puts $f1 { 2395 for {set x 0} {$x < 10} {incr x} { 2396 chan puts [chan gets $f1] 2397 } 2398 } 2399 chan close $f1 2400 set f1 [openpipe r $path(pipe)] 2401 set f2 [open $path(longfile) r] 2402 set y ok 2403 for {set x 0} {$x < 10} {incr x} { 2404 set l1 [chan gets $f1] 2405 set l2 [chan gets $f2] 2406 if {$l1 ne $l2} { 2407 set y broken:$x 2408 } 2409 } 2410 return $y 2411} -cleanup { 2412 chan close $f1 2413 chan close $f2 2414} -result ok 2415test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup { 2416 file delete $path(test1) 2417 file delete $path(pipe) 2418} -constraints stdio -body { 2419 set f1 [open $path(pipe) w] 2420 chan puts $f1 { 2421 chan puts [chan gets stdin] 2422 chan puts [chan gets stdin] 2423 } 2424 chan close $f1 2425 set y ok 2426 set f1 [openpipe r+ $path(pipe)] 2427 chan configure $f1 -buffering line 2428 set f2 [open $path(longfile) r] 2429 set line [chan gets $f2] 2430 chan puts $f1 $line 2431 set backline [chan gets $f1] 2432 if {$line ne $backline} { 2433 set y broken1 2434 } 2435 set line [chan gets $f2] 2436 chan puts $f1 $line 2437 set backline [chan gets $f1] 2438 if {$line ne $backline} { 2439 set y broken2 2440 } 2441 return $y 2442} -cleanup { 2443 chan close $f1 2444 chan close $f2 2445} -result ok 2446test chan-io-29.14 {Tcl_WriteChars, buffering and implicit flush at chan close} -setup { 2447 file delete $path(test3) 2448} -body { 2449 set f [open $path(test3) w] 2450 chan puts -nonewline $f "Text1" 2451 chan puts -nonewline $f " Text 2" 2452 chan puts $f " Text 3" 2453 chan close $f 2454 set f [open $path(test3) r] 2455 chan gets $f 2456} -cleanup { 2457 chan close $f 2458} -result {Text1 Text 2 Text 3} 2459test chan-io-29.15 {Tcl_Flush, channel not open for writing} -setup { 2460 file delete $path(test1) 2461 set fd [open $path(test1) w] 2462 chan close $fd 2463} -body { 2464 set fd [open $path(test1) r] 2465 chan flush $fd 2466} -returnCodes error -cleanup { 2467 catch {chan close $fd} 2468} -match glob -result {channel "*" wasn't opened for writing} 2469test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup { 2470 set fd [openpipe r cat longfile] 2471} -constraints stdio -body { 2472 chan flush $fd 2473} -returnCodes error -cleanup { 2474 catch {chan close $fd} 2475} -match glob -result {channel "*" wasn't opened for writing} 2476test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} -setup { 2477 file delete $path(test1) 2478} -body { 2479 set f1 [open $path(test1) w] 2480 chan configure $f1 -translation lf 2481 chan puts $f1 hello 2482 chan puts $f1 hello 2483 chan puts $f1 hello 2484 chan flush $f1 2485 file size $path(test1) 2486} -cleanup { 2487 chan close $f1 2488} -result 18 2489test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} -setup { 2490 file delete $path(test1) 2491 set x "" 2492 set f1 [open $path(test1) w] 2493} -body { 2494 chan configure $f1 -translation lf 2495 chan puts $f1 hello 2496 chan puts $f1 hello 2497 chan puts $f1 hello 2498 chan flush $f1 2499 lappend x [file size $path(test1)] 2500 chan puts $f1 hello 2501 chan flush $f1 2502 lappend x [file size $path(test1)] 2503 chan puts $f1 hello 2504 chan flush $f1 2505 lappend x [file size $path(test1)] 2506} -cleanup { 2507 chan close $f1 2508} -result {18 24 30} 2509test chan-io-29.19 {Explicit and implicit flushes} -setup { 2510 file delete $path(test1) 2511} -body { 2512 set f1 [open $path(test1) w] 2513 chan configure $f1 -translation lf -eofchar {} 2514 set x "" 2515 chan puts $f1 hello 2516 chan puts $f1 hello 2517 chan puts $f1 hello 2518 chan flush $f1 2519 lappend x [file size $path(test1)] 2520 chan puts $f1 hello 2521 chan flush $f1 2522 lappend x [file size $path(test1)] 2523 chan puts $f1 hello 2524 chan close $f1 2525 lappend x [file size $path(test1)] 2526} -result {18 24 30} 2527test chan-io-29.20 {Implicit flush when buffer is full} -setup { 2528 file delete $path(test1) 2529} -body { 2530 set f1 [open $path(test1) w] 2531 chan configure $f1 -translation lf -eofchar {} 2532 set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" 2533 for {set x 0} {$x < 100} {incr x} { 2534 chan puts $f1 $line 2535 } 2536 set z "" 2537 lappend z [file size $path(test1)] 2538 for {set x 0} {$x < 100} {incr x} { 2539 chan puts $f1 $line 2540 } 2541 lappend z [file size $path(test1)] 2542 chan close $f1 2543 lappend z [file size $path(test1)] 2544} -result {4096 12288 12600} 2545test chan-io-29.21 {Tcl_Flush to pipe} -setup { 2546 file delete $path(pipe) 2547} -constraints stdio -body { 2548 set f1 [open $path(pipe) w] 2549 chan puts $f1 {set x [chan read stdin 6]} 2550 chan puts $f1 {set cnt [string length $x]} 2551 chan puts $f1 {chan puts "read $cnt characters"} 2552 chan close $f1 2553 set f1 [openpipe r+ $path(pipe)] 2554 chan puts $f1 hello 2555 chan flush $f1 2556 chan gets $f1 2557} -cleanup { 2558 catch {chan close $f1} 2559} -result "read 6 characters" 2560test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { 2561 file delete $path(pipe) 2562} -constraints stdio -body { 2563 set f1 [open $path(pipe) w] 2564 chan puts $f1 { 2565 chan configure stdout -buffering full 2566 chan puts hello 2567 chan puts hello 2568 chan flush stdout 2569 chan gets stdin 2570 chan puts bye 2571 chan flush stdout 2572 } 2573 chan close $f1 2574 set f1 [openpipe r+ $path(pipe)] 2575 set x "" 2576 lappend x [chan gets $f1] 2577 lappend x [chan gets $f1] 2578 chan puts $f1 hello 2579 chan flush $f1 2580 lappend x [chan gets $f1] 2581} -cleanup { 2582 chan close $f1 2583} -result {hello hello bye} 2584test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup { 2585 file delete $path(pipe) 2586} -constraints stdio -body { 2587 set f1 [open $path(pipe) w] 2588 chan puts $f1 { 2589 chan puts hello 2590 chan puts hello 2591 chan gets stdin 2592 chan puts bye 2593 } 2594 chan close $f1 2595 set f1 [openpipe r+ $path(pipe)] 2596 set x "" 2597 lappend x [chan gets $f1] 2598 lappend x [chan gets $f1] 2599 chan puts $f1 hello 2600 chan flush $f1 2601 lappend x [chan gets $f1] 2602} -cleanup { 2603 chan close $f1 2604} -result {hello hello bye} 2605test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} -setup { 2606 variable x {} 2607} -body { 2608 set f [open $path(test3) w] 2609 chan puts $f "Line 1" 2610 chan puts $f "Line 2" 2611 set f2 [open $path(test3)] 2612 lappend x [chan read -nonewline $f2] 2613 chan close $f2 2614 chan flush $f 2615 set f2 [open $path(test3)] 2616 lappend x [chan read -nonewline $f2] 2617} -cleanup { 2618 chan close $f2 2619 chan close $f 2620} -result "{} {Line 1\nLine 2}" 2621test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { 2622 file delete $path(test3) 2623} -constraints {stdio fileevent} -body { 2624 set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)] 2625 chan puts $f "Line 1" 2626 chan puts $f "Line 2" 2627 chan close $f 2628 after 100 2629 set f [open $path(test3) r] 2630 chan read $f 2631} -cleanup { 2632 chan close $f 2633} -result "Line 1\nLine 2\n" 2634test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs} -body { 2635 set f [open "|[list cat -u]" r+] 2636 chan puts $f "Line1" 2637 chan flush $f 2638 chan gets $f 2639} -cleanup { 2640 chan close $f 2641} -result {Line1} 2642test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup { 2643 file delete $path(pipe) 2644 set f [open $path(pipe) w] 2645 chan puts $f {exit} 2646 chan close $f 2647} -constraints stdio -body { 2648 set f [openpipe r+ $path(pipe)] 2649 chan gets $f 2650 chan puts $f output 2651 after 50 2652 # 2653 # The flush below will get a SIGPIPE. This is an expected part of the test 2654 # and indicates that the test operates correctly. If you run this test 2655 # under a debugger, the signal will by intercepted unless you disable the 2656 # debugger's signal interception. 2657 # 2658 if {[catch {chan flush $f} msg]} { 2659 set x [list 1 $msg $::errorCode] 2660 catch {chan close $f} 2661 } elseif {[catch {chan close $f} msg]} { 2662 set x [list 1 $msg $::errorCode] 2663 } else { 2664 set x {this was supposed to fail and did not} 2665 } 2666 string tolower $x 2667} -match glob -result {1 {error flushing "*": broken pipe} {posix epipe {broken pipe}}} 2668test chan-io-29.28 {Tcl_WriteChars, lf mode} -setup { 2669 file delete $path(test1) 2670} -body { 2671 set f [open $path(test1) w] 2672 chan configure $f -translation lf -eofchar {} 2673 chan puts $f hello\nthere\nand\nhere 2674 chan flush $f 2675 file size $path(test1) 2676} -cleanup { 2677 chan close $f 2678} -result 21 2679test chan-io-29.29 {Tcl_WriteChars, cr mode} -setup { 2680 file delete $path(test1) 2681} -body { 2682 set f [open $path(test1) w] 2683 chan configure $f -translation cr -eofchar {} 2684 chan puts $f hello\nthere\nand\nhere 2685 chan close $f 2686 file size $path(test1) 2687} -result 21 2688test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup { 2689 file delete $path(test1) 2690} -body { 2691 set f [open $path(test1) w] 2692 chan configure $f -translation crlf -eofchar {} 2693 chan puts $f hello\nthere\nand\nhere 2694 chan close $f 2695 file size $path(test1) 2696} -result 25 2697test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { 2698 file delete $path(pipe) 2699 file delete $path(output) 2700} -constraints stdio -body { 2701 set f [open $path(pipe) w] 2702 chan puts $f "set f \[[list open $path(output) w]]" 2703 chan puts $f {chan configure $f -translation lf} 2704 set x [list while {![chan eof stdin]}] 2705 set x "$x {" 2706 chan puts $f $x 2707 chan puts $f { chan puts -nonewline $f [chan read stdin 4096]} 2708 chan puts $f { chan flush $f} 2709 chan puts $f "}" 2710 chan puts $f {chan close $f} 2711 chan close $f 2712 set x 01234567890123456789012345678901 2713 for {set i 0} {$i < 11} {incr i} { 2714 set x "$x$x" 2715 } 2716 set f [open $path(output) w] 2717 chan close $f 2718 set f [openpipe r+ $path(pipe)] 2719 chan configure $f -blocking off 2720 chan puts -nonewline $f $x 2721 chan close $f 2722 set counter 0 2723 while {([file size $path(output)] < 65536) && ($counter < 1000)} { 2724 after 10 [list incr [namespace which -variable counter]] 2725 vwait [namespace which -variable counter] 2726 } 2727 if {$counter == 1000} { 2728 set result "file size only [file size $path(output)]" 2729 } else { 2730 set result ok 2731 } 2732 # allow a little time for the background process to chan close. 2733 # otherwise, the following test fails on the [file delete $path(output)] 2734 # on Windows because a process still has the file open. 2735 after 100 set v 1; vwait v 2736 return $result 2737} -result ok 2738test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup { 2739 file delete $path(pipe) 2740 file delete $path(output) 2741} -constraints {stdio asyncPipeChan Close} -body { 2742 set f [open $path(pipe) w] 2743 chan puts $f "set f \[[list open $path(output) w]]" 2744 chan puts $f {chan configure $f -translation lf} 2745 set x [list while {![chan eof stdin]}] 2746 set x "$x \{" 2747 chan puts $f $x 2748 chan puts $f { after 20} 2749 chan puts $f { chan puts -nonewline $f [chan read stdin 1024]} 2750 chan puts $f { chan flush $f} 2751 chan puts $f "\}" 2752 chan puts $f {chan close $f} 2753 chan close $f 2754 set x 01234567890123456789012345678901 2755 for {set i 0} {$i < 11} {incr i} { 2756 set x "$x$x" 2757 } 2758 set f [open $path(output) w] 2759 chan close $f 2760 set f [openpipe r+ $path(pipe)] 2761 chan configure $f -blocking off 2762 chan puts -nonewline $f $x 2763 chan close $f 2764 set counter 0 2765 while {([file size $path(output)] < 65536) && ($counter < 1000)} { 2766 after 20 [list incr [namespace which -variable counter]] 2767 vwait [namespace which -variable counter] 2768 } 2769 if {$counter == 1000} { 2770 set result "file size only [file size $path(output)]" 2771 } else { 2772 set result ok 2773 } 2774} -result ok 2775test chan-io-29.33 {Tcl_Flush, implicit flush on exit} -setup { 2776 set f [open $path(script) w] 2777 chan puts $f "set f \[[list open $path(test1) w]]" 2778 chan puts $f {chan configure $f -translation lf 2779 chan puts $f hello 2780 chan puts $f bye 2781 chan puts $f strange 2782 } 2783 chan close $f 2784} -constraints exec -body { 2785 exec [interpreter] $path(script) 2786 set f [open $path(test1) r] 2787 chan read $f 2788} -cleanup { 2789 chan close $f 2790} -result "hello\nbye\nstrange\n" 2791test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -setup { 2792 variable c 0 2793 variable x running 2794 set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz 2795 proc writelots {s l} { 2796 for {set i 0} {$i < 2000} {incr i} { 2797 chan puts $s $l 2798 } 2799 } 2800} -constraints {socket tempNotMac fileevent notWinCI} -body { 2801 proc accept {s a p} { 2802 variable x 2803 chan event $s readable [namespace code [list readit $s]] 2804 chan configure $s -blocking off 2805 set x accepted 2806 } 2807 proc readit {s} { 2808 variable c 2809 variable x 2810 set l [chan gets $s] 2811 if {[chan eof $s]} { 2812 chan close $s 2813 set x done 2814 } elseif {([string length $l] > 0) || ![chan blocked $s]} { 2815 incr c 2816 } 2817 } 2818 set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 2819 set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] 2820 vwait [namespace which -variable x] 2821 chan configure $cs -blocking off 2822 writelots $cs $l 2823 chan close $cs 2824 chan close $ss 2825 vwait [namespace which -variable x] 2826 set c 2827} -result 2000 2828test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup { 2829 catch {interp delete x} 2830 catch {interp delete y} 2831} -constraints {socket tempNotMac fileevent} -body { 2832 # On Mac, this test screws up sockets such that subsequent tests using 2833 # port 2828 either cause errors or panic(). 2834 interp create x 2835 interp create y 2836 set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 2837 proc accept {s a p} { 2838 chan puts $s hello 2839 chan close $s 2840 } 2841 set c [socket 127.0.0.1 [lindex [chan configure $s -sockname] 2]] 2842 interp share {} $c x 2843 interp share {} $c y 2844 chan close $c 2845 x eval { 2846 proc readit {s} { 2847 chan gets $s 2848 if {[chan eof $s]} { 2849 chan close $s 2850 } 2851 } 2852 } 2853 y eval { 2854 proc readit {s} { 2855 chan gets $s 2856 if {[chan eof $s]} { 2857 chan close $s 2858 } 2859 } 2860 } 2861 x eval "chan event $c readable \{readit $c\}" 2862 y eval "chan event $c readable \{readit $c\}" 2863 y eval [list chan close $c] 2864 update 2865} -cleanup { 2866 chan close $s 2867 interp delete x 2868 interp delete y 2869} -result "" 2870 2871# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. 2872 2873test chan-io-30.1 {Tcl_Write lf, Tcl_Read lf} -setup { 2874 file delete $path(test1) 2875} -body { 2876 set f [open $path(test1) w] 2877 chan configure $f -translation lf 2878 chan puts $f hello\nthere\nand\nhere 2879 chan close $f 2880 set f [open $path(test1) r] 2881 chan configure $f -translation lf 2882 chan read $f 2883} -cleanup { 2884 chan close $f 2885} -result "hello\nthere\nand\nhere\n" 2886test chan-io-30.2 {Tcl_Write lf, Tcl_Read cr} -setup { 2887 file delete $path(test1) 2888} -body { 2889 set f [open $path(test1) w] 2890 chan configure $f -translation lf 2891 chan puts $f hello\nthere\nand\nhere 2892 chan close $f 2893 set f [open $path(test1) r] 2894 chan configure $f -translation cr 2895 chan read $f 2896} -cleanup { 2897 chan close $f 2898} -result "hello\nthere\nand\nhere\n" 2899test chan-io-30.3 {Tcl_Write lf, Tcl_Read crlf} -setup { 2900 file delete $path(test1) 2901} -body { 2902 set f [open $path(test1) w] 2903 chan configure $f -translation lf 2904 chan puts $f hello\nthere\nand\nhere 2905 chan close $f 2906 set f [open $path(test1) r] 2907 chan configure $f -translation crlf 2908 chan read $f 2909} -cleanup { 2910 chan close $f 2911} -result "hello\nthere\nand\nhere\n" 2912test chan-io-30.4 {Tcl_Write cr, Tcl_Read cr} -setup { 2913 file delete $path(test1) 2914} -body { 2915 set f [open $path(test1) w] 2916 chan configure $f -translation cr 2917 chan puts $f hello\nthere\nand\nhere 2918 chan close $f 2919 set f [open $path(test1) r] 2920 chan configure $f -translation cr 2921 chan read $f 2922} -cleanup { 2923 chan close $f 2924} -result "hello\nthere\nand\nhere\n" 2925test chan-io-30.5 {Tcl_Write cr, Tcl_Read lf} -setup { 2926 file delete $path(test1) 2927} -body { 2928 set f [open $path(test1) w] 2929 chan configure $f -translation cr 2930 chan puts $f hello\nthere\nand\nhere 2931 chan close $f 2932 set f [open $path(test1) r] 2933 chan configure $f -translation lf 2934 chan read $f 2935} -cleanup { 2936 chan close $f 2937} -result "hello\rthere\rand\rhere\r" 2938test chan-io-30.6 {Tcl_Write cr, Tcl_Read crlf} -setup { 2939 file delete $path(test1) 2940} -body { 2941 set f [open $path(test1) w] 2942 chan configure $f -translation cr 2943 chan puts $f hello\nthere\nand\nhere 2944 chan close $f 2945 set f [open $path(test1) r] 2946 chan configure $f -translation crlf 2947 chan read $f 2948} -cleanup { 2949 chan close $f 2950} -result "hello\rthere\rand\rhere\r" 2951test chan-io-30.7 {Tcl_Write crlf, Tcl_Read crlf} -setup { 2952 file delete $path(test1) 2953} -body { 2954 set f [open $path(test1) w] 2955 chan configure $f -translation crlf 2956 chan puts $f hello\nthere\nand\nhere 2957 chan close $f 2958 set f [open $path(test1) r] 2959 chan configure $f -translation crlf 2960 chan read $f 2961} -cleanup { 2962 chan close $f 2963} -result "hello\nthere\nand\nhere\n" 2964test chan-io-30.8 {Tcl_Write crlf, Tcl_Read lf} -setup { 2965 file delete $path(test1) 2966} -body { 2967 set f [open $path(test1) w] 2968 chan configure $f -translation crlf 2969 chan puts $f hello\nthere\nand\nhere 2970 chan close $f 2971 set f [open $path(test1) r] 2972 chan configure $f -translation lf 2973 chan read $f 2974} -cleanup { 2975 chan close $f 2976} -result "hello\r\nthere\r\nand\r\nhere\r\n" 2977test chan-io-30.9 {Tcl_Write crlf, Tcl_Read cr} -setup { 2978 file delete $path(test1) 2979} -body { 2980 set f [open $path(test1) w] 2981 chan configure $f -translation crlf 2982 chan puts $f hello\nthere\nand\nhere 2983 chan close $f 2984 set f [open $path(test1) r] 2985 chan configure $f -translation cr 2986 chan read $f 2987} -cleanup { 2988 chan close $f 2989} -result "hello\n\nthere\n\nand\n\nhere\n\n" 2990test chan-io-30.10 {Tcl_Write lf, Tcl_Read auto} -setup { 2991 file delete $path(test1) 2992} -body { 2993 set f [open $path(test1) w] 2994 chan configure $f -translation lf 2995 chan puts $f hello\nthere\nand\nhere 2996 chan close $f 2997 set f [open $path(test1) r] 2998 list [chan read $f] [chan configure $f -translation] 2999} -cleanup { 3000 chan close $f 3001} -result {{hello 3002there 3003and 3004here 3005} auto} 3006test chan-io-30.11 {Tcl_Write cr, Tcl_Read auto} -setup { 3007 file delete $path(test1) 3008} -body { 3009 set f [open $path(test1) w] 3010 chan configure $f -translation cr 3011 chan puts $f hello\nthere\nand\nhere 3012 chan close $f 3013 set f [open $path(test1) r] 3014 list [chan read $f] [chan configure $f -translation] 3015} -cleanup { 3016 chan close $f 3017} -result {{hello 3018there 3019and 3020here 3021} auto} 3022test chan-io-30.12 {Tcl_Write crlf, Tcl_Read auto} -setup { 3023 file delete $path(test1) 3024} -body { 3025 set f [open $path(test1) w] 3026 chan configure $f -translation crlf 3027 chan puts $f hello\nthere\nand\nhere 3028 chan close $f 3029 set f [open $path(test1) r] 3030 list [chan read $f] [chan configure $f -translation] 3031} -cleanup { 3032 chan close $f 3033} -result {{hello 3034there 3035and 3036here 3037} auto} 3038test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} -setup { 3039 file delete $path(test1) 3040} -body { 3041 set f [open $path(test1) w] 3042 chan configure $f -translation crlf 3043 set line "123456789ABCDE" ;# 14 char plus crlf 3044 chan puts -nonewline $f x ;# shift crlf across block boundary 3045 for {set i 0} {$i < 700} {incr i} { 3046 chan puts $f $line 3047 } 3048 chan close $f 3049 set f [open $path(test1) r] 3050 chan configure $f -translation auto 3051 string length [chan read $f] 3052} -cleanup { 3053 chan close $f 3054} -result [expr {700*15 + 1}] 3055test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { 3056 file delete $path(test1) 3057} -body { 3058 set f [open $path(test1) w] 3059 chan configure $f -translation crlf 3060 set line "123456789ABCDE" ;# 14 char plus crlf 3061 chan puts -nonewline $f x ;# shift crlf across block boundary 3062 for {set i 0} {$i < 700} {incr i} { 3063 chan puts $f $line 3064 } 3065 chan close $f 3066 set f [open $path(test1) r] 3067 chan configure $f -translation crlf 3068 string length [chan read $f] 3069} -cleanup { 3070 chan close $f 3071} -result [expr {700*15 + 1}] 3072test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup { 3073 file delete $path(test1) 3074} -body { 3075 set f [open $path(test1) w] 3076 chan configure $f -translation lf 3077 chan puts $f hello\nthere\nand\rhere 3078 chan close $f 3079 set f [open $path(test1) r] 3080 chan configure $f -translation auto 3081 chan read $f 3082} -cleanup { 3083 chan close $f 3084} -result {hello 3085there 3086and 3087here 3088} 3089test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { 3090 file delete $path(test1) 3091} -body { 3092 set f [open $path(test1) w] 3093 chan configure $f -translation lf 3094 chan puts -nonewline $f hello\nthere\nand\rhere\n\x1A 3095 chan close $f 3096 set f [open $path(test1) r] 3097 chan configure $f -translation auto -eofchar \x1A 3098 chan read $f 3099} -cleanup { 3100 chan close $f 3101} -result {hello 3102there 3103and 3104here 3105} 3106test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup { 3107 file delete $path(test1) 3108} -constraints {win} -body { 3109 set f [open $path(test1) w] 3110 chan configure $f -translation lf -eofchar \x1A 3111 chan puts $f hello\nthere\nand\rhere 3112 chan close $f 3113 set f [open $path(test1) r] 3114 chan configure $f -translation auto -eofchar \x1A 3115 chan read $f 3116} -cleanup { 3117 chan close $f 3118} -result {hello 3119there 3120and 3121here 3122} 3123test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup { 3124 file delete $path(test1) 3125} -body { 3126 set f [open $path(test1) w] 3127 chan configure $f -translation lf 3128 set s [format "abc\ndef\n%cghi\nqrs" 26] 3129 chan puts $f $s 3130 chan close $f 3131 set f [open $path(test1) r] 3132 chan configure $f -translation auto -eofchar \x1A 3133 set l "" 3134 lappend l [chan gets $f] 3135 lappend l [chan gets $f] 3136 lappend l [chan eof $f] 3137 lappend l [chan gets $f] 3138 lappend l [chan eof $f] 3139 lappend l [chan gets $f] 3140 lappend l [chan eof $f] 3141} -cleanup { 3142 chan close $f 3143} -result {abc def 0 {} 1 {} 1} 3144test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup { 3145 file delete $path(test1) 3146} -body { 3147 set f [open $path(test1) w] 3148 chan configure $f -translation lf 3149 set s [format "abc\ndef\n%cghi\nqrs" 26] 3150 chan puts $f $s 3151 chan close $f 3152 set f [open $path(test1) r] 3153 chan configure $f -translation auto -eofchar \x1A 3154 set l "" 3155 lappend l [chan gets $f] 3156 lappend l [chan gets $f] 3157 lappend l [chan eof $f] 3158 lappend l [chan gets $f] 3159 lappend l [chan eof $f] 3160 lappend l [chan gets $f] 3161 lappend l [chan eof $f] 3162} -cleanup { 3163 chan close $f 3164} -result {abc def 0 {} 1 {} 1} 3165test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup { 3166 file delete $path(test1) 3167 set l "" 3168} -body { 3169 set f [open $path(test1) w] 3170 chan configure $f -translation lf -eofchar {} 3171 chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] 3172 chan close $f 3173 set f [open $path(test1) r] 3174 chan configure $f -translation lf -eofchar {} 3175 lappend l [chan gets $f] 3176 lappend l [chan gets $f] 3177 lappend l [chan eof $f] 3178 lappend l [chan gets $f] 3179 lappend l [chan eof $f] 3180 lappend l [chan gets $f] 3181 lappend l [chan eof $f] 3182 lappend l [chan gets $f] 3183 lappend l [chan eof $f] 3184} -cleanup { 3185 chan close $f 3186} -result "abc def 0 \x1Aghi 0 qrs 0 {} 1" 3187test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup { 3188 file delete $path(test1) 3189 set l "" 3190} -body { 3191 set f [open $path(test1) w] 3192 chan configure $f -translation lf -eofchar {} 3193 chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] 3194 chan close $f 3195 set f [open $path(test1) r] 3196 chan configure $f -translation cr -eofchar {} 3197 set x [chan gets $f] 3198 lappend l [string equal $x "abc\ndef\n\x1Aghi\nqrs\n"] 3199 lappend l [chan eof $f] 3200 lappend l [chan gets $f] 3201 lappend l [chan eof $f] 3202} -cleanup { 3203 chan close $f 3204} -result {1 1 {} 1} 3205test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} -setup { 3206 file delete $path(test1) 3207 set l "" 3208} -body { 3209 set f [open $path(test1) w] 3210 chan configure $f -translation lf -eofchar {} 3211 chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] 3212 chan close $f 3213 set f [open $path(test1) r] 3214 chan configure $f -translation crlf -eofchar {} 3215 set x [chan gets $f] 3216 lappend l [string equal $x "abc\ndef\n\x1Aghi\nqrs\n"] 3217 lappend l [chan eof $f] 3218 lappend l [chan gets $f] 3219 lappend l [chan eof $f] 3220} -cleanup { 3221 chan close $f 3222} -result {1 1 {} 1} 3223test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup { 3224 file delete $path(test1) 3225} -body { 3226 set f [open $path(test1) w] 3227 chan configure $f -translation lf 3228 chan puts $f [format abc\ndef\n%cqrs\ntuv 26] 3229 chan close $f 3230 set f [open $path(test1) r] 3231 chan configure $f -translation auto -eofchar \x1A 3232 list [string length [chan read $f]] [chan eof $f] 3233} -cleanup { 3234 chan close $f 3235} -result {8 1} 3236test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup { 3237 file delete $path(test1) 3238} -body { 3239 set f [open $path(test1) w] 3240 chan configure $f -translation lf 3241 set c [format abc\ndef\n%cqrs\ntuv 26] 3242 chan puts $f $c 3243 chan close $f 3244 set f [open $path(test1) r] 3245 chan configure $f -translation lf -eofchar \x1A 3246 list [string length [chan read $f]] [chan eof $f] 3247} -cleanup { 3248 chan close $f 3249} -result {8 1} 3250test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup { 3251 file delete $path(test1) 3252} -body { 3253 set f [open $path(test1) w] 3254 chan configure $f -translation cr 3255 set c [format abc\ndef\n%cqrs\ntuv 26] 3256 chan puts $f $c 3257 chan close $f 3258 set f [open $path(test1) r] 3259 chan configure $f -translation auto -eofchar \x1A 3260 list [string length [chan read $f]] [chan eof $f] 3261} -cleanup { 3262 chan close $f 3263} -result {8 1} 3264test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup { 3265 file delete $path(test1) 3266} -body { 3267 set f [open $path(test1) w] 3268 chan configure $f -translation cr 3269 set c [format abc\ndef\n%cqrs\ntuv 26] 3270 chan puts $f $c 3271 chan close $f 3272 set f [open $path(test1) r] 3273 chan configure $f -translation cr -eofchar \x1A 3274 list [string length [chan read $f]] [chan eof $f] 3275} -cleanup { 3276 chan close $f 3277} -result {8 1} 3278test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup { 3279 file delete $path(test1) 3280} -body { 3281 set f [open $path(test1) w] 3282 chan configure $f -translation crlf 3283 set c [format abc\ndef\n%cqrs\ntuv 26] 3284 chan puts $f $c 3285 chan close $f 3286 set f [open $path(test1) r] 3287 chan configure $f -translation auto -eofchar \x1A 3288 list [string length [chan read $f]] [chan eof $f] 3289} -cleanup { 3290 chan close $f 3291} -result {8 1} 3292test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup { 3293 file delete $path(test1) 3294} -body { 3295 set f [open $path(test1) w] 3296 chan configure $f -translation crlf 3297 set c [format abc\ndef\n%cqrs\ntuv 26] 3298 chan puts $f $c 3299 chan close $f 3300 set f [open $path(test1) r] 3301 chan configure $f -translation crlf -eofchar \x1A 3302 list [string length [chan read $f]] [chan eof $f] 3303} -cleanup { 3304 chan close $f 3305} -result {8 1} 3306 3307# Test end of line translations. Functions tested are Tcl_Write and 3308# Tcl_Gets. 3309 3310test chan-io-31.1 {Tcl_Write lf, Tcl_Gets auto} -setup { 3311 file delete $path(test1) 3312 set l "" 3313} -body { 3314 set f [open $path(test1) w] 3315 chan configure $f -translation lf 3316 chan puts $f hello\nthere\nand\nhere 3317 chan close $f 3318 set f [open $path(test1) r] 3319 lappend l [chan gets $f] 3320 lappend l [chan tell $f] 3321 lappend l [chan configure $f -translation] 3322 lappend l [chan gets $f] 3323 lappend l [chan tell $f] 3324 lappend l [chan configure $f -translation] 3325} -cleanup { 3326 chan close $f 3327} -result {hello 6 auto there 12 auto} 3328test chan-io-31.2 {Tcl_Write cr, Tcl_Gets auto} -setup { 3329 file delete $path(test1) 3330 set l "" 3331} -body { 3332 set f [open $path(test1) w] 3333 chan configure $f -translation cr 3334 chan puts $f hello\nthere\nand\nhere 3335 chan close $f 3336 set f [open $path(test1) r] 3337 lappend l [chan gets $f] 3338 lappend l [chan tell $f] 3339 lappend l [chan configure $f -translation] 3340 lappend l [chan gets $f] 3341 lappend l [chan tell $f] 3342 lappend l [chan configure $f -translation] 3343} -cleanup { 3344 chan close $f 3345} -result {hello 6 auto there 12 auto} 3346test chan-io-31.3 {Tcl_Write crlf, Tcl_Gets auto} -setup { 3347 file delete $path(test1) 3348 set l "" 3349} -body { 3350 set f [open $path(test1) w] 3351 chan configure $f -translation crlf 3352 chan puts $f hello\nthere\nand\nhere 3353 chan close $f 3354 set f [open $path(test1) r] 3355 lappend l [chan gets $f] 3356 lappend l [chan tell $f] 3357 lappend l [chan configure $f -translation] 3358 lappend l [chan gets $f] 3359 lappend l [chan tell $f] 3360 lappend l [chan configure $f -translation] 3361} -cleanup { 3362 chan close $f 3363} -result {hello 7 auto there 14 auto} 3364test chan-io-31.4 {Tcl_Write lf, Tcl_Gets lf} -setup { 3365 file delete $path(test1) 3366 set l "" 3367} -body { 3368 set f [open $path(test1) w] 3369 chan configure $f -translation lf 3370 chan puts $f hello\nthere\nand\nhere 3371 chan close $f 3372 set f [open $path(test1) r] 3373 chan configure $f -translation lf 3374 lappend l [chan gets $f] 3375 lappend l [chan tell $f] 3376 lappend l [chan configure $f -translation] 3377 lappend l [chan gets $f] 3378 lappend l [chan tell $f] 3379 lappend l [chan configure $f -translation] 3380} -cleanup { 3381 chan close $f 3382} -result {hello 6 lf there 12 lf} 3383test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} -setup { 3384 file delete $path(test1) 3385 set l "" 3386} -body { 3387 set f [open $path(test1) w] 3388 chan configure $f -translation lf 3389 chan puts $f hello\nthere\nand\nhere 3390 chan close $f 3391 set f [open $path(test1) r] 3392 chan configure $f -translation cr 3393 lappend l [string length [chan gets $f]] 3394 lappend l [chan tell $f] 3395 lappend l [chan configure $f -translation] 3396 lappend l [chan eof $f] 3397 lappend l [chan gets $f] 3398 lappend l [chan tell $f] 3399 lappend l [chan configure $f -translation] 3400 lappend l [chan eof $f] 3401} -cleanup { 3402 chan close $f 3403} -result {21 21 cr 1 {} 21 cr 1} 3404test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} -setup { 3405 file delete $path(test1) 3406 set l "" 3407} -body { 3408 set f [open $path(test1) w] 3409 chan configure $f -translation lf 3410 chan puts $f hello\nthere\nand\nhere 3411 chan close $f 3412 set f [open $path(test1) r] 3413 chan configure $f -translation crlf 3414 lappend l [string length [chan gets $f]] 3415 lappend l [chan tell $f] 3416 lappend l [chan configure $f -translation] 3417 lappend l [chan eof $f] 3418 lappend l [chan gets $f] 3419 lappend l [chan tell $f] 3420 lappend l [chan configure $f -translation] 3421 lappend l [chan eof $f] 3422} -cleanup { 3423 chan close $f 3424} -result {21 21 crlf 1 {} 21 crlf 1} 3425test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} -setup { 3426 file delete $path(test1) 3427 set l "" 3428} -body { 3429 set f [open $path(test1) w] 3430 chan configure $f -translation cr 3431 chan puts $f hello\nthere\nand\nhere 3432 chan close $f 3433 set f [open $path(test1) r] 3434 chan configure $f -translation cr 3435 lappend l [chan gets $f] 3436 lappend l [chan tell $f] 3437 lappend l [chan configure $f -translation] 3438 lappend l [chan eof $f] 3439 lappend l [chan gets $f] 3440 lappend l [chan tell $f] 3441 lappend l [chan configure $f -translation] 3442 lappend l [chan eof $f] 3443} -cleanup { 3444 chan close $f 3445} -result {hello 6 cr 0 there 12 cr 0} 3446test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} -setup { 3447 file delete $path(test1) 3448 set l "" 3449} -body { 3450 set f [open $path(test1) w] 3451 chan configure $f -translation cr 3452 chan puts $f hello\nthere\nand\nhere 3453 chan close $f 3454 set f [open $path(test1) r] 3455 chan configure $f -translation lf 3456 lappend l [string length [chan gets $f]] 3457 lappend l [chan tell $f] 3458 lappend l [chan configure $f -translation] 3459 lappend l [chan eof $f] 3460 lappend l [chan gets $f] 3461 lappend l [chan tell $f] 3462 lappend l [chan configure $f -translation] 3463 lappend l [chan eof $f] 3464} -cleanup { 3465 chan close $f 3466} -result {21 21 lf 1 {} 21 lf 1} 3467test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} -setup { 3468 file delete $path(test1) 3469 set l "" 3470} -body { 3471 set f [open $path(test1) w] 3472 chan configure $f -translation cr 3473 chan puts $f hello\nthere\nand\nhere 3474 chan close $f 3475 set f [open $path(test1) r] 3476 chan configure $f -translation crlf 3477 lappend l [string length [chan gets $f]] 3478 lappend l [chan tell $f] 3479 lappend l [chan configure $f -translation] 3480 lappend l [chan eof $f] 3481 lappend l [chan gets $f] 3482 lappend l [chan tell $f] 3483 lappend l [chan configure $f -translation] 3484 lappend l [chan eof $f] 3485} -cleanup { 3486 chan close $f 3487} -result {21 21 crlf 1 {} 21 crlf 1} 3488test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} -setup { 3489 file delete $path(test1) 3490 set l "" 3491} -body { 3492 set f [open $path(test1) w] 3493 chan configure $f -translation crlf 3494 chan puts $f hello\nthere\nand\nhere 3495 chan close $f 3496 set f [open $path(test1) r] 3497 chan configure $f -translation crlf 3498 lappend l [chan gets $f] 3499 lappend l [chan tell $f] 3500 lappend l [chan configure $f -translation] 3501 lappend l [chan eof $f] 3502 lappend l [chan gets $f] 3503 lappend l [chan tell $f] 3504 lappend l [chan configure $f -translation] 3505 lappend l [chan eof $f] 3506} -cleanup { 3507 chan close $f 3508} -result {hello 7 crlf 0 there 14 crlf 0} 3509test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} -setup { 3510 file delete $path(test1) 3511 set l "" 3512} -body { 3513 set f [open $path(test1) w] 3514 chan configure $f -translation crlf 3515 chan puts $f hello\nthere\nand\nhere 3516 chan close $f 3517 set f [open $path(test1) r] 3518 chan configure $f -translation cr 3519 lappend l [chan gets $f] 3520 lappend l [chan tell $f] 3521 lappend l [chan configure $f -translation] 3522 lappend l [chan eof $f] 3523 lappend l [string length [chan gets $f]] 3524 lappend l [chan tell $f] 3525 lappend l [chan configure $f -translation] 3526 lappend l [chan eof $f] 3527} -cleanup { 3528 chan close $f 3529} -result {hello 6 cr 0 6 13 cr 0} 3530test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} -setup { 3531 file delete $path(test1) 3532 set l "" 3533} -body { 3534 set f [open $path(test1) w] 3535 chan configure $f -translation crlf 3536 chan puts $f hello\nthere\nand\nhere 3537 chan close $f 3538 set f [open $path(test1) r] 3539 chan configure $f -translation lf 3540 lappend l [string length [chan gets $f]] 3541 lappend l [chan tell $f] 3542 lappend l [chan configure $f -translation] 3543 lappend l [chan eof $f] 3544 lappend l [string length [chan gets $f]] 3545 lappend l [chan tell $f] 3546 lappend l [chan configure $f -translation] 3547 lappend l [chan eof $f] 3548} -cleanup { 3549 chan close $f 3550} -result {6 7 lf 0 6 14 lf 0} 3551test chan-io-31.13 {binary mode is synonym of lf mode} -setup { 3552 file delete $path(test1) 3553} -body { 3554 set f [open $path(test1) w] 3555 chan configure $f -translation binary 3556 chan configure $f -translation 3557} -cleanup { 3558 chan close $f 3559} -result lf 3560# 3561# Test chan-io-9.14 has been removed because "auto" output translation mode is 3562# not supoprted. 3563# 3564test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} -setup { 3565 file delete $path(test1) 3566 set l "" 3567} -body { 3568 set f [open $path(test1) w] 3569 chan configure $f -translation lf 3570 chan puts $f hello\nthere\rand\r\nhere 3571 chan close $f 3572 set f [open $path(test1) r] 3573 chan configure $f -translation auto 3574 lappend l [chan gets $f] 3575 lappend l [chan gets $f] 3576 lappend l [chan gets $f] 3577 lappend l [chan gets $f] 3578 lappend l [chan eof $f] 3579 lappend l [chan gets $f] 3580 lappend l [chan eof $f] 3581} -cleanup { 3582 chan close $f 3583} -result {hello there and here 0 {} 1} 3584test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} -setup { 3585 file delete $path(test1) 3586 set l "" 3587} -body { 3588 set f [open $path(test1) w] 3589 chan configure $f -translation lf 3590 chan puts -nonewline $f hello\nthere\rand\r\nhere\r 3591 chan close $f 3592 set f [open $path(test1) r] 3593 chan configure $f -translation auto 3594 lappend l [chan gets $f] 3595 lappend l [chan gets $f] 3596 lappend l [chan gets $f] 3597 lappend l [chan gets $f] 3598 lappend l [chan eof $f] 3599 lappend l [chan gets $f] 3600 lappend l [chan eof $f] 3601} -cleanup { 3602 chan close $f 3603} -result {hello there and here 0 {} 1} 3604test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} -setup { 3605 file delete $path(test1) 3606 set l "" 3607} -body { 3608 set f [open $path(test1) w] 3609 chan configure $f -translation lf 3610 chan puts -nonewline $f hello\nthere\rand\r\nhere\n 3611 chan close $f 3612 set f [open $path(test1) r] 3613 lappend l [chan gets $f] 3614 lappend l [chan gets $f] 3615 lappend l [chan gets $f] 3616 lappend l [chan gets $f] 3617 lappend l [chan eof $f] 3618 lappend l [chan gets $f] 3619 lappend l [chan eof $f] 3620} -cleanup { 3621 chan close $f 3622} -result {hello there and here 0 {} 1} 3623test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} -setup { 3624 file delete $path(test1) 3625 set l "" 3626} -body { 3627 set f [open $path(test1) w] 3628 chan configure $f -translation lf 3629 chan puts -nonewline $f hello\nthere\rand\r\nhere\r\n 3630 chan close $f 3631 set f [open $path(test1) r] 3632 chan configure $f -translation auto 3633 lappend l [chan gets $f] 3634 lappend l [chan gets $f] 3635 lappend l [chan gets $f] 3636 lappend l [chan gets $f] 3637 lappend l [chan eof $f] 3638 lappend l [chan gets $f] 3639 lappend l [chan eof $f] 3640} -cleanup { 3641 chan close $f 3642} -result {hello there and here 0 {} 1} 3643test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup { 3644 file delete $path(test1) 3645 set l "" 3646} -body { 3647 set f [open $path(test1) w] 3648 chan configure $f -translation lf 3649 chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26] 3650 chan close $f 3651 set f [open $path(test1) r] 3652 chan configure $f -translation auto -eofchar \x1A 3653 lappend l [chan gets $f] 3654 lappend l [chan gets $f] 3655 lappend l [chan gets $f] 3656 lappend l [chan gets $f] 3657 lappend l [chan eof $f] 3658 lappend l [chan gets $f] 3659 lappend l [chan eof $f] 3660} -cleanup { 3661 chan close $f 3662} -result {hello there and here 0 {} 1} 3663test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup { 3664 file delete $path(test1) 3665 set l "" 3666} -body { 3667 set f [open $path(test1) w] 3668 chan configure $f -translation lf -eofchar \x1A 3669 chan puts $f hello\nthere\nand\rhere 3670 chan close $f 3671 set f [open $path(test1) r] 3672 chan configure $f -translation auto -eofchar \x1A 3673 lappend l [chan gets $f] 3674 lappend l [chan gets $f] 3675 lappend l [chan gets $f] 3676 lappend l [chan gets $f] 3677 lappend l [chan eof $f] 3678 lappend l [chan gets $f] 3679 lappend l [chan eof $f] 3680} -cleanup { 3681 chan close $f 3682} -result {hello there and here 0 {} 1} 3683test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup { 3684 file delete $path(test1) 3685 set l "" 3686} -body { 3687 set f [open $path(test1) w] 3688 chan configure $f -translation lf 3689 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3690 chan close $f 3691 set f [open $path(test1) r] 3692 chan configure $f -translation auto -eofchar \x1A 3693 lappend l [chan gets $f] 3694 lappend l [chan gets $f] 3695 lappend l [chan eof $f] 3696 lappend l [chan gets $f] 3697 lappend l [chan eof $f] 3698} -cleanup { 3699 chan close $f 3700} -result {abc def 0 {} 1} 3701test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} -setup { 3702 file delete $path(test1) 3703 set l "" 3704} -body { 3705 set f [open $path(test1) w] 3706 chan configure $f -translation lf 3707 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3708 chan close $f 3709 set f [open $path(test1) r] 3710 chan configure $f -translation auto -eofchar \x1A 3711 lappend l [chan gets $f] 3712 lappend l [chan gets $f] 3713 lappend l [chan eof $f] 3714 lappend l [chan gets $f] 3715 lappend l [chan eof $f] 3716} -cleanup { 3717 chan close $f 3718} -result {abc def 0 {} 1} 3719test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup { 3720 file delete $path(test1) 3721 set l "" 3722} -body { 3723 set f [open $path(test1) w] 3724 chan configure $f -translation lf -eofchar {} 3725 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3726 chan close $f 3727 set f [open $path(test1) r] 3728 chan configure $f -translation lf -eofchar {} 3729 lappend l [chan gets $f] 3730 lappend l [chan gets $f] 3731 lappend l [chan eof $f] 3732 lappend l [chan gets $f] 3733 lappend l [chan eof $f] 3734 lappend l [chan gets $f] 3735 lappend l [chan eof $f] 3736 lappend l [chan gets $f] 3737 lappend l [chan eof $f] 3738} -cleanup { 3739 chan close $f 3740} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1" 3741test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup { 3742 file delete $path(test1) 3743 set l "" 3744} -body { 3745 set f [open $path(test1) w] 3746 chan configure $f -translation cr -eofchar {} 3747 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3748 chan close $f 3749 set f [open $path(test1) r] 3750 chan configure $f -translation cr -eofchar {} 3751 lappend l [chan gets $f] 3752 lappend l [chan gets $f] 3753 lappend l [chan eof $f] 3754 lappend l [chan gets $f] 3755 lappend l [chan eof $f] 3756 lappend l [chan gets $f] 3757 lappend l [chan eof $f] 3758 lappend l [chan gets $f] 3759 lappend l [chan eof $f] 3760} -cleanup { 3761 chan close $f 3762} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1" 3763test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup { 3764 file delete $path(test1) 3765 set l "" 3766} -body { 3767 set f [open $path(test1) w] 3768 chan configure $f -translation crlf -eofchar {} 3769 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3770 chan close $f 3771 set f [open $path(test1) r] 3772 chan configure $f -translation crlf -eofchar {} 3773 lappend l [chan gets $f] 3774 lappend l [chan gets $f] 3775 lappend l [chan eof $f] 3776 lappend l [chan gets $f] 3777 lappend l [chan eof $f] 3778 lappend l [chan gets $f] 3779 lappend l [chan eof $f] 3780 lappend l [chan gets $f] 3781 lappend l [chan eof $f] 3782} -cleanup { 3783 chan close $f 3784} -result "abc def 0 \x1Aqrs 0 tuv 0 {} 1" 3785test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { 3786 file delete $path(test1) 3787 set l "" 3788} -body { 3789 set f [open $path(test1) w] 3790 chan configure $f -translation lf 3791 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3792 chan close $f 3793 set f [open $path(test1) r] 3794 chan configure $f -translation auto -eofchar \x1A 3795 lappend l [chan gets $f] 3796 lappend l [chan gets $f] 3797 lappend l [chan eof $f] 3798 lappend l [chan gets $f] 3799 lappend l [chan eof $f] 3800} -cleanup { 3801 chan close $f 3802} -result {abc def 0 {} 1} 3803test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup { 3804 file delete $path(test1) 3805 set l "" 3806} -body { 3807 set f [open $path(test1) w] 3808 chan configure $f -translation lf 3809 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3810 chan close $f 3811 set f [open $path(test1) r] 3812 chan configure $f -translation lf -eofchar \x1A 3813 lappend l [chan gets $f] 3814 lappend l [chan gets $f] 3815 lappend l [chan eof $f] 3816 lappend l [chan gets $f] 3817 lappend l [chan eof $f] 3818} -cleanup { 3819 chan close $f 3820} -result {abc def 0 {} 1} 3821test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup { 3822 file delete $path(test1) 3823 set l "" 3824} -body { 3825 set f [open $path(test1) w] 3826 chan configure $f -translation cr -eofchar {} 3827 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3828 chan close $f 3829 set f [open $path(test1) r] 3830 chan configure $f -translation auto -eofchar \x1A 3831 lappend l [chan gets $f] 3832 lappend l [chan gets $f] 3833 lappend l [chan eof $f] 3834 lappend l [chan gets $f] 3835 lappend l [chan eof $f] 3836} -cleanup { 3837 chan close $f 3838} -result {abc def 0 {} 1} 3839test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup { 3840 file delete $path(test1) 3841 set l "" 3842} -body { 3843 set f [open $path(test1) w] 3844 chan configure $f -translation cr -eofchar {} 3845 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3846 chan close $f 3847 set f [open $path(test1) r] 3848 chan configure $f -translation cr -eofchar \x1A 3849 lappend l [chan gets $f] 3850 lappend l [chan gets $f] 3851 lappend l [chan eof $f] 3852 lappend l [chan gets $f] 3853 lappend l [chan eof $f] 3854} -cleanup { 3855 chan close $f 3856} -result {abc def 0 {} 1} 3857test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup { 3858 file delete $path(test1) 3859 set l "" 3860} -body { 3861 set f [open $path(test1) w] 3862 chan configure $f -translation crlf -eofchar {} 3863 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3864 chan close $f 3865 set f [open $path(test1) r] 3866 chan configure $f -translation auto -eofchar \x1A 3867 lappend l [chan gets $f] 3868 lappend l [chan gets $f] 3869 lappend l [chan eof $f] 3870 lappend l [chan gets $f] 3871 lappend l [chan eof $f] 3872} -cleanup { 3873 chan close $f 3874} -result {abc def 0 {} 1} 3875test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup { 3876 file delete $path(test1) 3877 set l "" 3878} -body { 3879 set f [open $path(test1) w] 3880 chan configure $f -translation crlf -eofchar {} 3881 chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] 3882 chan close $f 3883 set f [open $path(test1) r] 3884 chan configure $f -translation crlf -eofchar \x1A 3885 lappend l [chan gets $f] 3886 lappend l [chan gets $f] 3887 lappend l [chan eof $f] 3888 lappend l [chan gets $f] 3889 lappend l [chan eof $f] 3890} -cleanup { 3891 chan close $f 3892} -result {abc def 0 {} 1} 3893test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup { 3894 file delete $path(test1) 3895 set c "" 3896} -body { 3897 set f [open $path(test1) w] 3898 chan configure $f -translation crlf 3899 set line "123456789ABCDE" ;# 14 char plus crlf 3900 chan puts -nonewline $f x ;# shift crlf across block boundary 3901 for {set i 0} {$i < 700} {incr i} { 3902 chan puts $f $line 3903 } 3904 chan close $f 3905 set f [open $path(test1) r] 3906 chan configure $f -translation crlf 3907 while {[chan gets $f line] >= 0} { 3908 append c $line\n 3909 } 3910 chan close $f 3911 string length $c 3912} -result [expr {700*15 + 1}] 3913test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { 3914 file delete $path(test1) 3915 set c "" 3916} -body { 3917 set f [open $path(test1) w] 3918 chan configure $f -translation crlf 3919 set line "123456789ABCDE" ;# 14 char plus crlf 3920 chan puts -nonewline $f x ;# shift crlf across block boundary 3921 for {set i 0} {$i < 700} {incr i} { 3922 chan puts $f $line 3923 } 3924 chan close $f 3925 set f [open $path(test1) r] 3926 chan configure $f -translation auto 3927 while {[chan gets $f line] >= 0} { 3928 append c $line\n 3929 } 3930 chan close $f 3931 string length $c 3932} -result [expr {700*15 + 1}] 3933 3934# Test Tcl_Read and buffering. 3935 3936test chan-io-32.1 {Tcl_Read, channel not readable} -body { 3937 read stdout 3938} -returnCodes error -result {channel "stdout" wasn't opened for reading} 3939test chan-io-32.2 {Tcl_Read, zero byte count} { 3940 chan read stdin 0 3941} "" 3942test chan-io-32.3 {Tcl_Read, negative byte count} -setup { 3943 set f [open $path(longfile) r] 3944} -body { 3945 chan read $f -1 3946} -returnCodes error -cleanup { 3947 chan close $f 3948} -result {expected non-negative integer but got "-1"} 3949test chan-io-32.4 {Tcl_Read, positive byte count} -body { 3950 set f [open $path(longfile) r] 3951 string length [chan read $f 1024] 3952} -cleanup { 3953 chan close $f 3954} -result 1024 3955test chan-io-32.5 {Tcl_Read, multiple buffers} -body { 3956 set f [open $path(longfile) r] 3957 chan configure $f -buffersize 100 3958 string length [chan read $f 1024] 3959} -cleanup { 3960 chan close $f 3961} -result 1024 3962test chan-io-32.6 {Tcl_Read, very large read} { 3963 set f1 [open $path(longfile) r] 3964 set z [chan read $f1 1000000] 3965 chan close $f1 3966 set l [string length $z] 3967 set x ok 3968 set z [file size $path(longfile)] 3969 if {$z != $l} { 3970 set x "$z != $l" 3971 } 3972 set x 3973} ok 3974test chan-io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { 3975 set f1 [open $path(longfile) r] 3976 chan configure $f1 -blocking off 3977 set z [chan read $f1 20] 3978 chan close $f1 3979 set l [string length $z] 3980 set x ok 3981 if {$l != 20} { 3982 set x "$l != 20" 3983 } 3984 set x 3985} ok 3986test chan-io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { 3987 set f1 [open $path(longfile) r] 3988 chan configure $f1 -blocking off 3989 set z [chan read $f1 1000000] 3990 chan close $f1 3991 set x ok 3992 set l [string length $z] 3993 set z [file size $path(longfile)] 3994 if {$z != $l} { 3995 set x "$z != $l" 3996 } 3997 set x 3998} ok 3999test chan-io-32.9 {Tcl_Read, read to end of file} { 4000 set f1 [open $path(longfile) r] 4001 set z [chan read $f1] 4002 chan close $f1 4003 set l [string length $z] 4004 set x ok 4005 set z [file size $path(longfile)] 4006 if {$z != $l} { 4007 set x "$z != $l" 4008 } 4009 set x 4010} ok 4011test chan-io-32.10 {Tcl_Read from a pipe} -setup { 4012 file delete $path(pipe) 4013} -constraints stdio -body { 4014 set f1 [open $path(pipe) w] 4015 chan puts $f1 {chan puts [chan gets stdin]} 4016 chan close $f1 4017 set f1 [openpipe r+ $path(pipe)] 4018 chan puts $f1 hello 4019 chan flush $f1 4020 chan read $f1 4021} -cleanup { 4022 chan close $f1 4023} -result "hello\n" 4024test chan-io-32.11 {Tcl_Read from a pipe} -setup { 4025 file delete $path(pipe) 4026 set x "" 4027} -constraints stdio -body { 4028 set f1 [open $path(pipe) w] 4029 chan puts $f1 {chan puts [chan gets stdin]} 4030 chan puts $f1 {chan puts [chan gets stdin]} 4031 chan close $f1 4032 set f1 [openpipe r+ $path(pipe)] 4033 chan puts $f1 hello 4034 chan flush $f1 4035 lappend x [chan read $f1 6] 4036 chan puts $f1 hello 4037 chan flush $f1 4038 lappend x [chan read $f1] 4039} -cleanup { 4040 chan close $f1 4041} -result {{hello 4042} {hello 4043}} 4044test chan-io-32.12 {Tcl_Read, -nonewline} -setup { 4045 file delete $path(test1) 4046} -body { 4047 set f1 [open $path(test1) w] 4048 chan puts $f1 hello 4049 chan puts $f1 bye 4050 chan close $f1 4051 set f1 [open $path(test1) r] 4052 chan read -nonewline $f1 4053} -cleanup { 4054 chan close $f1 4055} -result {hello 4056bye} 4057test chan-io-32.13 {Tcl_Read, -nonewline} -setup { 4058 file delete $path(test1) 4059} -body { 4060 set f1 [open $path(test1) w] 4061 chan puts $f1 hello 4062 chan puts $f1 bye 4063 chan close $f1 4064 set f1 [open $path(test1) r] 4065 set c [chan read -nonewline $f1] 4066 list [string length $c] $c 4067} -cleanup { 4068 chan close $f1 4069} -result {9 {hello 4070bye}} 4071test chan-io-32.14 {Tcl_Read, reading in small chunks} -setup { 4072 file delete $path(test1) 4073} -body { 4074 set f [open $path(test1) w] 4075 chan puts $f "Two lines: this one" 4076 chan puts $f "and this one" 4077 chan close $f 4078 set f [open $path(test1)] 4079 list [chan read $f 1] [chan read $f 2] [chan read $f] 4080} -cleanup { 4081 chan close $f 4082} -result {T wo { lines: this one 4083and this one 4084}} 4085test chan-io-32.15 {Tcl_Read, asking for more input than available} -setup { 4086 file delete $path(test1) 4087} -body { 4088 set f [open $path(test1) w] 4089 chan puts $f "Two lines: this one" 4090 chan puts $f "and this one" 4091 chan close $f 4092 set f [open $path(test1)] 4093 chan read $f 100 4094} -cleanup { 4095 chan close $f 4096} -result {Two lines: this one 4097and this one 4098} 4099test chan-io-32.16 {Tcl_Read, read to end of file with -nonewline} -setup { 4100 file delete $path(test1) 4101} -body { 4102 set f [open $path(test1) w] 4103 chan puts $f "Two lines: this one" 4104 chan puts $f "and this one" 4105 chan close $f 4106 set f [open $path(test1)] 4107 chan read -nonewline $f 4108} -cleanup { 4109 chan close $f 4110} -result {Two lines: this one 4111and this one} 4112 4113# Test Tcl_Gets. 4114 4115test chan-io-33.1 {Tcl_Gets, reading what was written} -setup { 4116 file delete $path(test1) 4117} -body { 4118 set f1 [open $path(test1) w] 4119 chan puts $f1 "first line" 4120 chan close $f1 4121 set f1 [open $path(test1) r] 4122 chan gets $f1 4123} -cleanup { 4124 chan close $f1 4125} -result {first line} 4126test chan-io-33.2 {Tcl_Gets into variable} { 4127 set f1 [open $path(longfile) r] 4128 set c [chan gets $f1 x] 4129 set l [string length x] 4130 set z ok 4131 if {$l != $l} { 4132 set z broken 4133 } 4134 chan close $f1 4135 set z 4136} ok 4137test chan-io-33.3 {Tcl_Gets from pipe} -setup { 4138 file delete $path(pipe) 4139} -constraints stdio -body { 4140 set f1 [open $path(pipe) w] 4141 chan puts $f1 {chan puts [chan gets stdin]} 4142 chan close $f1 4143 set f1 [openpipe r+ $path(pipe)] 4144 chan puts $f1 hello 4145 chan flush $f1 4146 chan gets $f1 4147} -cleanup { 4148 chan close $f1 4149} -result hello 4150test chan-io-33.4 {Tcl_Gets with long line} -setup { 4151 file delete $path(test3) 4152} -body { 4153 set f [open $path(test3) w] 4154 chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4155 chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4156 chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4157 chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4158 chan puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4159 chan close $f 4160 set f [open $path(test3)] 4161 chan gets $f 4162} -cleanup { 4163 chan close $f 4164} -result {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} 4165test chan-io-33.5 {Tcl_Gets with long line} -setup { 4166 set f [open $path(test3) w] 4167 puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4168 puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4169 puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4170 puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4171 puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4172 close $f 4173} -body { 4174 set f [open $path(test3)] 4175 set x [chan gets $f y] 4176 chan close $f 4177 list $x $y 4178} -result {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} 4179test chan-io-33.6 {Tcl_Gets and end of file} -setup { 4180 file delete $path(test3) 4181 set x {} 4182} -body { 4183 set f [open $path(test3) w] 4184 chan puts -nonewline $f "Test1\nTest2" 4185 chan close $f 4186 set f [open $path(test3)] 4187 set y {} 4188 lappend x [chan gets $f y] $y 4189 set y {} 4190 lappend x [chan gets $f y] $y 4191 set y {} 4192 lappend x [chan gets $f y] $y 4193} -cleanup { 4194 chan close $f 4195} -result {5 Test1 5 Test2 -1 {}} 4196test chan-io-33.7 {Tcl_Gets and bad variable} -setup { 4197 set f [open $path(test3) w] 4198 chan puts $f "Line 1" 4199 chan puts $f "Line 2" 4200 chan close $f 4201 catch {unset x} 4202 set f [open $path(test3) r] 4203} -body { 4204 set x 24 4205 chan gets $f x(0) 4206} -returnCodes error -cleanup { 4207 chan close $f 4208} -result {can't set "x(0)": variable isn't array} 4209test chan-io-33.8 {Tcl_Gets, exercising double buffering} { 4210 set f [open $path(test3) w] 4211 chan configure $f -translation lf -eofchar {} 4212 set x "" 4213 for {set y 0} {$y < 99} {incr y} {set x "a$x"} 4214 for {set y 0} {$y < 100} {incr y} {chan puts $f $x} 4215 chan close $f 4216 set f [open $path(test3) r] 4217 chan configure $f -translation lf 4218 for {set y 0} {$y < 100} {incr y} {chan gets $f} 4219 chan close $f 4220 set y 4221} 100 4222test chan-io-33.9 {Tcl_Gets, exercising double buffering} { 4223 set f [open $path(test3) w] 4224 chan configure $f -translation lf -eofchar {} 4225 set x "" 4226 for {set y 0} {$y < 99} {incr y} {set x "a$x"} 4227 for {set y 0} {$y < 200} {incr y} {chan puts $f $x} 4228 chan close $f 4229 set f [open $path(test3) r] 4230 chan configure $f -translation lf 4231 for {set y 0} {$y < 200} {incr y} {chan gets $f} 4232 chan close $f 4233 set y 4234} 200 4235test chan-io-33.10 {Tcl_Gets, exercising double buffering} { 4236 set f [open $path(test3) w] 4237 chan configure $f -translation lf -eofchar {} 4238 set x "" 4239 for {set y 0} {$y < 99} {incr y} {set x "a$x"} 4240 for {set y 0} {$y < 300} {incr y} {chan puts $f $x} 4241 chan close $f 4242 set f [open $path(test3) r] 4243 chan configure $f -translation lf 4244 for {set y 0} {$y < 300} {incr y} {chan gets $f} 4245 chan close $f 4246 set y 4247} 300 4248 4249# Test Tcl_Seek and Tcl_Tell. 4250 4251test chan-io-34.1 {Tcl_Seek to current position at start of file} -body { 4252 set f1 [open $path(longfile) r] 4253 chan seek $f1 0 current 4254 chan tell $f1 4255} -cleanup { 4256 chan close $f1 4257} -result 0 4258test chan-io-34.2 {Tcl_Seek to offset from start} -setup { 4259 file delete $path(test1) 4260} -body { 4261 set f1 [open $path(test1) w] 4262 chan configure $f1 -translation lf -eofchar {} 4263 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4264 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4265 chan close $f1 4266 set f1 [open $path(test1) r] 4267 chan seek $f1 10 start 4268 chan tell $f1 4269} -cleanup { 4270 chan close $f1 4271} -result 10 4272test chan-io-34.3 {Tcl_Seek to end of file} -setup { 4273 file delete $path(test1) 4274} -body { 4275 set f1 [open $path(test1) w] 4276 chan configure $f1 -translation lf -eofchar {} 4277 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4278 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4279 chan close $f1 4280 set f1 [open $path(test1) r] 4281 chan seek $f1 0 end 4282 chan tell $f1 4283} -cleanup { 4284 chan close $f1 4285} -result 54 4286test chan-io-34.4 {Tcl_Seek to offset from end of file} -setup { 4287 file delete $path(test1) 4288} -body { 4289 set f1 [open $path(test1) w] 4290 chan configure $f1 -translation lf -eofchar {} 4291 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4292 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4293 chan close $f1 4294 set f1 [open $path(test1) r] 4295 chan seek $f1 -10 end 4296 chan tell $f1 4297} -cleanup { 4298 chan close $f1 4299} -result 44 4300test chan-io-34.5 {Tcl_Seek to offset from current position} -setup { 4301 file delete $path(test1) 4302} -body { 4303 set f1 [open $path(test1) w] 4304 chan configure $f1 -translation lf -eofchar {} 4305 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4306 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4307 chan close $f1 4308 set f1 [open $path(test1) r] 4309 chan seek $f1 10 current 4310 chan seek $f1 10 current 4311 chan tell $f1 4312} -cleanup { 4313 chan close $f1 4314} -result 20 4315test chan-io-34.6 {Tcl_Seek to offset from end of file} -setup { 4316 file delete $path(test1) 4317} -body { 4318 set f1 [open $path(test1) w] 4319 chan configure $f1 -translation lf -eofchar {} 4320 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4321 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4322 chan close $f1 4323 set f1 [open $path(test1) r] 4324 chan seek $f1 -10 end 4325 list [chan tell $f1] [chan read $f1] 4326} -cleanup { 4327 chan close $f1 4328} -result {44 {rstuvwxyz 4329}} 4330test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} -setup { 4331 file delete $path(test1) 4332} -body { 4333 set f1 [open $path(test1) w] 4334 chan configure $f1 -translation lf -eofchar {} 4335 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4336 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4337 chan close $f1 4338 set f1 [open $path(test1) r] 4339 chan seek $f1 -10 end 4340 set c1 [chan tell $f1] 4341 set r1 [chan read $f1 5] 4342 chan seek $f1 0 current 4343 list $c1 $r1 [chan tell $f1] 4344} -cleanup { 4345 chan close $f1 4346} -result {44 rstuv 49} 4347test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup { 4348 set pipe [openpipe] 4349} -constraints stdio -body { 4350 chan seek $pipe 0 current 4351} -returnCodes error -cleanup { 4352 chan close $pipe 4353} -match glob -result {error during seek on "*": invalid argument} 4354test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup { 4355 file delete $path(test3) 4356} -body { 4357 set f [open $path(test3) w] 4358 chan configure $f -eofchar {} 4359 chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 4360 chan close $f 4361 set f [open $path(test3) RDWR] 4362 set x [chan read $f 1] 4363 chan seek $f 3 4364 lappend x [chan read $f 1] 4365 chan seek $f 0 start 4366 lappend x [chan read $f 1] 4367 chan seek $f 10 current 4368 lappend x [chan read $f 1] 4369 chan seek $f -2 end 4370 lappend x [chan read $f 1] 4371 chan seek $f 50 end 4372 lappend x [chan read $f 1] 4373 chan seek $f 1 4374 lappend x [chan read $f 1] 4375} -cleanup { 4376 chan close $f 4377} -result {a d a l Y {} b} 4378set path(test3) [makeFile {} test3] 4379test chan-io-34.10 {Tcl_Seek testing flushing of buffered input} { 4380 set f [open $path(test3) w] 4381 chan configure $f -translation lf 4382 chan puts $f xyz\n123 4383 chan close $f 4384 set f [open $path(test3) r+] 4385 chan configure $f -translation lf 4386 set x [chan gets $f] 4387 chan seek $f 0 current 4388 chan puts $f 456 4389 chan close $f 4390 list $x [viewFile test3] 4391} "xyz {xyz 4392456}" 4393test chan-io-34.11 {Tcl_Seek testing flushing of buffered output} { 4394 set f [open $path(test3) w] 4395 chan puts $f xyz\n123 4396 chan close $f 4397 set f [open $path(test3) w+] 4398 chan puts $f xyzzy 4399 chan seek $f 2 4400 set x [chan gets $f] 4401 chan close $f 4402 list $x [viewFile test3] 4403} "zzy xyzzy" 4404test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} { 4405 set f [open $path(test3) w] 4406 chan configure $f -translation lf -eofchar {} 4407 chan puts $f xyz\n123 4408 chan close $f 4409 set f [open $path(test3) a+] 4410 chan configure $f -translation lf -eofchar {} 4411 chan puts $f xyzzy 4412 chan flush $f 4413 set x [chan tell $f] 4414 chan seek $f -4 cur 4415 set y [chan gets $f] 4416 chan close $f 4417 list $x [viewFile test3] $y 4418} {14 {xyz 4419123 4420xyzzy} zzy} 4421test chan-io-34.13 {Tcl_Tell at start of file} -setup { 4422 file delete $path(test1) 4423} -body { 4424 set f1 [open $path(test1) w] 4425 chan tell $f1 4426} -cleanup { 4427 chan close $f1 4428} -result 0 4429test chan-io-34.14 {Tcl_Tell after seek to end of file} -setup { 4430 file delete $path(test1) 4431} -body { 4432 set f1 [open $path(test1) w] 4433 chan configure $f1 -translation lf -eofchar {} 4434 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4435 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4436 chan close $f1 4437 set f1 [open $path(test1) r] 4438 chan seek $f1 0 end 4439 chan tell $f1 4440} -cleanup { 4441 chan close $f1 4442} -result 54 4443test chan-io-34.15 {Tcl_Tell combined with seeking} -setup { 4444 file delete $path(test1) 4445} -body { 4446 set f1 [open $path(test1) w] 4447 chan configure $f1 -translation lf -eofchar {} 4448 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4449 chan puts $f1 "abcdefghijklmnopqrstuvwxyz" 4450 chan close $f1 4451 set f1 [open $path(test1) r] 4452 chan seek $f1 10 start 4453 set c1 [chan tell $f1] 4454 chan seek $f1 10 current 4455 list $c1 [chan tell $f1] 4456} -cleanup { 4457 chan close $f1 4458} -result {10 20} 4459test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints stdio -body { 4460 set f1 [openpipe] 4461 chan tell $f1 4462} -cleanup { 4463 chan close $f1 4464} -result -1 4465test chan-io-34.17 {Tcl_Tell on pipe: always -1} stdio { 4466 set f1 [openpipe] 4467 chan puts $f1 {chan puts hello} 4468 chan flush $f1 4469 set c [chan tell $f1] 4470 chan gets $f1 4471 chan close $f1 4472 set c 4473} -1 4474test chan-io-34.18 {Tcl_Tell combined with seeking and reading} -setup { 4475 file delete $path(test2) 4476} -body { 4477 set f [open $path(test2) w] 4478 chan configure $f -translation lf -eofchar {} 4479 chan puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" 4480 chan close $f 4481 set f [open $path(test2)] 4482 chan configure $f -translation lf 4483 set x [chan tell $f] 4484 chan read $f 3 4485 lappend x [chan tell $f] 4486 chan seek $f 2 4487 lappend x [chan tell $f] 4488 chan seek $f 10 current 4489 lappend x [chan tell $f] 4490 chan seek $f 0 end 4491 lappend x [chan tell $f] 4492} -cleanup { 4493 chan close $f 4494} -result {0 3 2 12 30} 4495test chan-io-34.19 {Tcl_Tell combined with opening in append mode} -body { 4496 set f [open $path(test3) w] 4497 chan configure $f -translation lf -eofchar {} 4498 chan puts $f "abcdefghijklmnopqrstuvwxyz" 4499 chan puts $f "abcdefghijklmnopqrstuvwxyz" 4500 chan close $f 4501 set f [open $path(test3) a] 4502 chan tell $f 4503} -cleanup { 4504 chan close $f 4505} -result 54 4506test chan-io-34.20 {Tcl_Tell combined with writing} -setup { 4507 set l "" 4508} -body { 4509 set f [open $path(test3) w] 4510 chan seek $f 29 start 4511 lappend l [chan tell $f] 4512 chan puts -nonewline $f a 4513 chan seek $f 39 start 4514 lappend l [chan tell $f] 4515 chan puts -nonewline $f a 4516 lappend l [chan tell $f] 4517 chan seek $f 407 end 4518 lappend l [chan tell $f] 4519} -cleanup { 4520 chan close $f 4521} -result {29 39 40 447} 4522test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup { 4523 file delete $path(test3) 4524 set l "" 4525} -constraints {largefileSupport} -body { 4526 set f [open $path(test3) w] 4527 chan configure $f -encoding binary 4528 lappend l [chan tell $f] 4529 chan puts -nonewline $f abcdef 4530 lappend l [chan tell $f] 4531 chan flush $f 4532 lappend l [chan tell $f] 4533 # 4GB offset! 4534 chan seek $f 0x100000000 4535 lappend l [chan tell $f] 4536 chan puts -nonewline $f abcdef 4537 lappend l [chan tell $f] 4538 chan close $f 4539 lappend l [file size $path(test3)] 4540 # truncate... 4541 chan close [open $path(test3) w] 4542 lappend l [file size $path(test3)] 4543} -result {0 6 6 4294967296 4294967302 4294967302 0} 4544 4545# Test Tcl_Eof 4546 4547test chan-io-35.1 {Tcl_Eof} -setup { 4548 file delete $path(test1) 4549} -body { 4550 set f [open $path(test1) w] 4551 chan puts $f hello 4552 chan puts $f hello 4553 chan close $f 4554 set f [open $path(test1)] 4555 set x [chan eof $f] 4556 lappend x [chan eof $f] 4557 chan gets $f 4558 lappend x [chan eof $f] 4559 chan gets $f 4560 lappend x [chan eof $f] 4561 chan gets $f 4562 lappend x [chan eof $f] 4563 lappend x [chan eof $f] 4564} -cleanup { 4565 chan close $f 4566} -result {0 0 0 0 1 1} 4567test chan-io-35.2 {Tcl_Eof with pipe} -constraints stdio -setup { 4568 file delete $path(pipe) 4569} -body { 4570 set f1 [open $path(pipe) w] 4571 chan puts $f1 {chan gets stdin} 4572 chan puts $f1 {chan puts hello} 4573 chan close $f1 4574 set f1 [openpipe r+ $path(pipe)] 4575 chan puts $f1 hello 4576 set x [chan eof $f1] 4577 chan flush $f1 4578 lappend x [chan eof $f1] 4579 chan gets $f1 4580 lappend x [chan eof $f1] 4581 chan gets $f1 4582 lappend x [chan eof $f1] 4583} -cleanup { 4584 chan close $f1 4585} -result {0 0 0 1} 4586test chan-io-35.3 {Tcl_Eof with pipe} -constraints stdio -setup { 4587 file delete $path(pipe) 4588} -body { 4589 set f1 [open $path(pipe) w] 4590 chan puts $f1 {chan gets stdin} 4591 chan puts $f1 {chan puts hello} 4592 chan close $f1 4593 set f1 [openpipe r+ $path(pipe)] 4594 chan puts $f1 hello 4595 set x [chan eof $f1] 4596 chan flush $f1 4597 lappend x [chan eof $f1] 4598 chan gets $f1 4599 lappend x [chan eof $f1] 4600 chan gets $f1 4601 lappend x [chan eof $f1] 4602 chan gets $f1 4603 lappend x [chan eof $f1] 4604 chan gets $f1 4605 lappend x [chan eof $f1] 4606} -cleanup { 4607 chan close $f1 4608} -result {0 0 0 1 1 1} 4609test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} -setup { 4610 file delete $path(test1) 4611 set l "" 4612} -constraints {nonBlockFiles} -body { 4613 chan close [open $path(test1) w] 4614 set f [open $path(test1) r] 4615 chan configure $f -blocking off 4616 lappend l [chan gets $f] 4617 lappend l [chan eof $f] 4618} -cleanup { 4619 chan close $f 4620} -result {{} 1} 4621test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup { 4622 file delete $path(pipe) 4623 set l "" 4624} -constraints stdio -body { 4625 set f [open $path(pipe) w] 4626 chan puts $f { 4627 exit 4628 } 4629 chan close $f 4630 set f [openpipe r $path(pipe)] 4631 lappend l [chan gets $f] 4632 lappend l [chan eof $f] 4633} -cleanup { 4634 chan close $f 4635} -result {{} 1} 4636test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup { 4637 file delete $path(test1) 4638} -body { 4639 set f [open $path(test1) w] 4640 chan configure $f -translation lf -eofchar \x1A 4641 chan puts $f abc\ndef 4642 chan close $f 4643 set s [file size $path(test1)] 4644 set f [open $path(test1) r] 4645 chan configure $f -translation auto -eofchar \x1A 4646 list $s [string length [chan read $f]] [chan eof $f] 4647} -cleanup { 4648 chan close $f 4649} -result {9 8 1} 4650test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { 4651 file delete $path(test1) 4652} -body { 4653 set f [open $path(test1) w] 4654 chan configure $f -translation lf -eofchar \x1A 4655 chan puts $f abc\ndef 4656 chan close $f 4657 set s [file size $path(test1)] 4658 set f [open $path(test1) r] 4659 chan configure $f -translation lf -eofchar \x1A 4660 list $s [string length [chan read $f]] [chan eof $f] 4661} -cleanup { 4662 chan close $f 4663} -result {9 8 1} 4664test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { 4665 file delete $path(test1) 4666} -body { 4667 set f [open $path(test1) w] 4668 chan configure $f -translation cr -eofchar \x1A 4669 chan puts $f abc\ndef 4670 chan close $f 4671 set s [file size $path(test1)] 4672 set f [open $path(test1) r] 4673 chan configure $f -translation auto -eofchar \x1A 4674 list $s [string length [chan read $f]] [chan eof $f] 4675} -cleanup { 4676 chan close $f 4677} -result {9 8 1} 4678test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { 4679 file delete $path(test1) 4680} -body { 4681 set f [open $path(test1) w] 4682 chan configure $f -translation cr -eofchar \x1A 4683 chan puts $f abc\ndef 4684 chan close $f 4685 set s [file size $path(test1)] 4686 set f [open $path(test1) r] 4687 chan configure $f -translation cr -eofchar \x1A 4688 list $s [string length [chan read $f]] [chan eof $f] 4689} -cleanup { 4690 chan close $f 4691} -result {9 8 1} 4692test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { 4693 file delete $path(test1) 4694} -body { 4695 set f [open $path(test1) w] 4696 chan configure $f -translation crlf -eofchar \x1A 4697 chan puts $f abc\ndef 4698 chan close $f 4699 set s [file size $path(test1)] 4700 set f [open $path(test1) r] 4701 chan configure $f -translation auto -eofchar \x1A 4702 list $s [string length [chan read $f]] [chan eof $f] 4703} -cleanup { 4704 chan close $f 4705} -result {11 8 1} 4706test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { 4707 file delete $path(test1) 4708} -body { 4709 set f [open $path(test1) w] 4710 chan configure $f -translation crlf -eofchar \x1A 4711 chan puts $f abc\ndef 4712 chan close $f 4713 set s [file size $path(test1)] 4714 set f [open $path(test1) r] 4715 chan configure $f -translation crlf -eofchar \x1A 4716 list $s [string length [chan read $f]] [chan eof $f] 4717} -cleanup { 4718 chan close $f 4719} -result {11 8 1} 4720test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { 4721 file delete $path(test1) 4722} -body { 4723 set f [open $path(test1) w] 4724 chan configure $f -translation lf -eofchar {} 4725 chan puts $f [format abc\ndef\n%cqrs\nuvw 26] 4726 chan close $f 4727 set c [file size $path(test1)] 4728 set f [open $path(test1) r] 4729 chan configure $f -translation auto -eofchar \x1A 4730 list $c [string length [chan read $f]] [chan eof $f] 4731} -cleanup { 4732 chan close $f 4733} -result {17 8 1} 4734test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup { 4735 file delete $path(test1) 4736} -body { 4737 set f [open $path(test1) w] 4738 chan configure $f -translation lf -eofchar {} 4739 chan puts $f [format abc\ndef\n%cqrs\nuvw 26] 4740 chan close $f 4741 set c [file size $path(test1)] 4742 set f [open $path(test1) r] 4743 chan configure $f -translation lf -eofchar \x1A 4744 list $c [string length [chan read $f]] [chan eof $f] 4745} -cleanup { 4746 chan close $f 4747} -result {17 8 1} 4748test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup { 4749 file delete $path(test1) 4750} -body { 4751 set f [open $path(test1) w] 4752 chan configure $f -translation cr -eofchar {} 4753 chan puts $f [format abc\ndef\n%cqrs\nuvw 26] 4754 chan close $f 4755 set c [file size $path(test1)] 4756 set f [open $path(test1) r] 4757 chan configure $f -translation auto -eofchar \x1A 4758 list $c [string length [chan read $f]] [chan eof $f] 4759} -cleanup { 4760 chan close $f 4761} -result {17 8 1} 4762test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup { 4763 file delete $path(test1) 4764} -body { 4765 set f [open $path(test1) w] 4766 chan configure $f -translation cr -eofchar {} 4767 chan puts $f [format abc\ndef\n%cqrs\nuvw 26] 4768 chan close $f 4769 set c [file size $path(test1)] 4770 set f [open $path(test1) r] 4771 chan configure $f -translation cr -eofchar \x1A 4772 list $c [string length [chan read $f]] [chan eof $f] 4773} -cleanup { 4774 chan close $f 4775} -result {17 8 1} 4776test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup { 4777 file delete $path(test1) 4778} -body { 4779 set f [open $path(test1) w] 4780 chan configure $f -translation crlf -eofchar {} 4781 chan puts $f [format abc\ndef\n%cqrs\nuvw 26] 4782 chan close $f 4783 set c [file size $path(test1)] 4784 set f [open $path(test1) r] 4785 chan configure $f -translation auto -eofchar \x1A 4786 list $c [string length [chan read $f]] [chan eof $f] 4787} -cleanup { 4788 chan close $f 4789} -result {21 8 1} 4790test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { 4791 file delete $path(test1) 4792} -body { 4793 set f [open $path(test1) w] 4794 chan configure $f -translation crlf -eofchar {} 4795 chan puts $f [format abc\ndef\n%cqrs\nuvw 26] 4796 chan close $f 4797 set c [file size $path(test1)] 4798 set f [open $path(test1) r] 4799 chan configure $f -translation crlf -eofchar \x1A 4800 list $c [string length [chan read $f]] [chan eof $f] 4801} -cleanup { 4802 chan close $f 4803} -result {21 8 1} 4804 4805# Test Tcl_InputBlocked 4806 4807test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { 4808 set x "" 4809} -constraints stdio -body { 4810 set f1 [openpipe] 4811 chan puts $f1 {chan puts hello_from_pipe} 4812 chan flush $f1 4813 chan gets $f1 4814 chan configure $f1 -blocking off -buffering full 4815 chan puts $f1 {chan puts hello} 4816 lappend x [chan gets $f1] 4817 lappend x [chan blocked $f1] 4818 chan flush $f1 4819 after 200 4820 lappend x [chan gets $f1] 4821 lappend x [chan blocked $f1] 4822 lappend x [chan gets $f1] 4823 lappend x [chan blocked $f1] 4824} -cleanup { 4825 chan close $f1 4826} -result {{} 1 hello 0 {} 1} 4827test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup { 4828 set x "" 4829} -constraints stdio -body { 4830 set f1 [openpipe] 4831 chan configure $f1 -buffering line 4832 chan puts $f1 {chan puts hello_from_pipe} 4833 lappend x [chan gets $f1] 4834 lappend x [chan blocked $f1] 4835 chan puts $f1 {exit} 4836 lappend x [chan gets $f1] 4837 lappend x [chan blocked $f1] 4838 lappend x [chan eof $f1] 4839} -cleanup { 4840 chan close $f1 4841} -result {hello_from_pipe 0 {} 0 1} 4842test chan-io-36.3 {Tcl_InputBlocked vs files, short read} -setup { 4843 file delete $path(test1) 4844 set l "" 4845} -body { 4846 set f [open $path(test1) w] 4847 chan puts $f abcdefghijklmnop 4848 chan close $f 4849 set f [open $path(test1) r] 4850 lappend l [chan blocked $f] 4851 lappend l [chan read $f 3] 4852 lappend l [chan blocked $f] 4853 lappend l [chan read -nonewline $f] 4854 lappend l [chan blocked $f] 4855 lappend l [chan eof $f] 4856} -cleanup { 4857 chan close $f 4858} -result {0 abc 0 defghijklmnop 0 1} 4859test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} -setup { 4860 file delete $path(test1) 4861 set l "" 4862 variable x 4863} -constraints {fileevent} -body { 4864 set f [open $path(test1) w] 4865 chan puts $f abcdefghijklmnop 4866 chan close $f 4867 set f [open $path(test1) r] 4868 chan event $f readable [namespace code { 4869 lappend l [chan read $f 3] 4870 if {[chan eof $f]} {lappend l eof; chan close $f; set x done} 4871 }] 4872 vwait [namespace which -variable x] 4873 return $l 4874} -result {abc def ghi jkl mno {p 4875} eof} 4876test chan-io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} -setup { 4877 file delete $path(test1) 4878 set l "" 4879} -constraints {nonBlockFiles} -body { 4880 set f [open $path(test1) w] 4881 chan puts $f abcdefghijklmnop 4882 chan close $f 4883 set f [open $path(test1) r] 4884 chan configure $f -blocking off 4885 lappend l [chan blocked $f] 4886 lappend l [chan read $f 3] 4887 lappend l [chan blocked $f] 4888 lappend l [chan read -nonewline $f] 4889 lappend l [chan blocked $f] 4890 lappend l [chan eof $f] 4891} -cleanup { 4892 chan close $f 4893} -result {0 abc 0 defghijklmnop 0 1} 4894test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} -setup { 4895 file delete $path(test1) 4896 set l "" 4897 variable x 4898} -constraints {nonBlockFiles fileevent} -body { 4899 set f [open $path(test1) w] 4900 chan puts $f abcdefghijklmnop 4901 chan close $f 4902 set f [open $path(test1) r] 4903 chan configure $f -blocking off 4904 chan event $f readable [namespace code { 4905 lappend l [chan read $f 3] 4906 if {[chan eof $f]} {lappend l eof; chan close $f; set x done} 4907 }] 4908 vwait [namespace which -variable x] 4909 return $l 4910} -result {abc def ghi jkl mno {p 4911} eof} 4912 4913# Test Tcl_InputBuffered 4914 4915test chan-io-37.1 {Tcl_InputBuffered} -setup { 4916 set l "" 4917} -constraints {testchannel} -body { 4918 set f [open $path(longfile) r] 4919 chan configure $f -buffersize 4096 4920 chan read $f 3 4921 lappend l [testchannel inputbuffered $f] 4922 lappend l [chan tell $f] 4923} -cleanup { 4924 chan close $f 4925} -result {4093 3} 4926test chan-io-37.2 {Tcl_InputBuffered, test input flushing on seek} -setup { 4927 set l "" 4928} -constraints {testchannel} -body { 4929 set f [open $path(longfile) r] 4930 chan configure $f -buffersize 4096 4931 chan read $f 3 4932 lappend l [testchannel inputbuffered $f] 4933 lappend l [chan tell $f] 4934 chan seek $f 0 current 4935 lappend l [testchannel inputbuffered $f] 4936 lappend l [chan tell $f] 4937} -cleanup { 4938 chan close $f 4939} -result {4093 3 0 3} 4940 4941# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize 4942 4943test chan-io-38.1 {Tcl_GetChannelBufferSize, default buffer size} -body { 4944 set f [open $path(longfile) r] 4945 chan configure $f -buffersize 4946} -cleanup { 4947 chan close $f 4948} -result 4096 4949test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} -setup { 4950 set l "" 4951} -body { 4952 set f [open $path(longfile) r] 4953 lappend l [chan configure $f -buffersize] 4954 chan configure $f -buffersize 10000 4955 lappend l [chan configure $f -buffersize] 4956 chan configure $f -buffersize 1 4957 lappend l [chan configure $f -buffersize] 4958 chan configure $f -buffersize -1 4959 lappend l [chan configure $f -buffersize] 4960 chan configure $f -buffersize 0 4961 lappend l [chan configure $f -buffersize] 4962 chan configure $f -buffersize 100000 4963 lappend l [chan configure $f -buffersize] 4964 chan configure $f -buffersize 10000000 4965 lappend l [chan configure $f -buffersize] 4966} -cleanup { 4967 chan close $f 4968} -result {4096 10000 1 1 1 100000 1048576} 4969test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { 4970 # This test crashes the interp if Bug #427196 is not fixed 4971 set chan [open [info script] r] 4972 chan configure $chan -buffersize 10 4973 set var [chan read $chan 2] 4974 chan configure $chan -buffersize 32 4975 append var [chan read $chan] 4976 chan close $chan 4977} {} 4978 4979# Test Tcl_SetChannelOption, Tcl_GetChannelOption 4980 4981test chan-io-39.1 {Tcl_GetChannelOption} -setup { 4982 file delete $path(test1) 4983} -body { 4984 set f1 [open $path(test1) w] 4985 chan configure $f1 -blocking 4986} -cleanup { 4987 chan close $f1 4988} -result 1 4989# 4990# Test 17.2 was removed. 4991# 4992test chan-io-39.2 {Tcl_GetChannelOption} -setup { 4993 file delete $path(test1) 4994} -body { 4995 set f1 [open $path(test1) w] 4996 chan configure $f1 -buffering 4997} -cleanup { 4998 chan close $f1 4999} -result full 5000test chan-io-39.3 {Tcl_GetChannelOption} -setup { 5001 file delete $path(test1) 5002} -body { 5003 set f1 [open $path(test1) w] 5004 chan configure $f1 -buffering line 5005 chan configure $f1 -buffering 5006} -cleanup { 5007 chan close $f1 5008} -result line 5009test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} -setup { 5010 file delete $path(test1) 5011 set l "" 5012} -body { 5013 set f1 [open $path(test1) w] 5014 lappend l [chan configure $f1 -buffering] 5015 chan configure $f1 -buffering line 5016 lappend l [chan configure $f1 -buffering] 5017 chan configure $f1 -buffering none 5018 lappend l [chan configure $f1 -buffering] 5019 chan configure $f1 -buffering line 5020 lappend l [chan configure $f1 -buffering] 5021 chan configure $f1 -buffering full 5022 lappend l [chan configure $f1 -buffering] 5023} -cleanup { 5024 chan close $f1 5025} -result {full line none line full} 5026test chan-io-39.5 {Tcl_GetChannelOption, invariance} -setup { 5027 file delete $path(test1) 5028 set l "" 5029} -body { 5030 set f1 [open $path(test1) w] 5031 lappend l [chan configure $f1 -buffering] 5032 lappend l [list [catch {chan configure $f1 -buffering green} msg] $msg] 5033 lappend l [chan configure $f1 -buffering] 5034} -cleanup { 5035 chan close $f1 5036} -result {full {1 {bad value for -buffering: must be one of full, line, or none}} full} 5037test chan-io-39.6 {Tcl_SetChannelOption, multiple options} -setup { 5038 file delete $path(test1) 5039} -body { 5040 set f1 [open $path(test1) w] 5041 chan configure $f1 -translation lf -buffering line 5042 chan puts $f1 hello 5043 chan puts $f1 bye 5044 file size $path(test1) 5045} -cleanup { 5046 chan close $f1 5047} -result 10 5048test chan-io-39.7 {Tcl_SetChannelOption, buffering, translation} -setup { 5049 file delete $path(test1) 5050 set x "" 5051} -body { 5052 set f1 [open $path(test1) w] 5053 chan configure $f1 -translation lf 5054 chan puts $f1 hello 5055 chan puts $f1 bye 5056 chan configure $f1 -buffering line 5057 lappend x [file size $path(test1)] 5058 chan puts $f1 really_bye 5059 lappend x [file size $path(test1)] 5060} -cleanup { 5061 chan close $f1 5062} -result {0 21} 5063test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} -setup { 5064 file delete $path(test1) 5065 set l "" 5066} -body { 5067 set f1 [open $path(test1) w] 5068 chan configure $f1 -translation lf -buffering none -eofchar {} 5069 chan puts -nonewline $f1 hello 5070 lappend l [file size $path(test1)] 5071 chan puts -nonewline $f1 hello 5072 lappend l [file size $path(test1)] 5073 chan configure $f1 -buffering full 5074 chan puts -nonewline $f1 hello 5075 lappend l [file size $path(test1)] 5076 chan configure $f1 -buffering none 5077 lappend l [file size $path(test1)] 5078 chan puts -nonewline $f1 hello 5079 lappend l [file size $path(test1)] 5080 chan close $f1 5081 lappend l [file size $path(test1)] 5082} -result {5 10 10 10 20 20} 5083test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} -setup { 5084 file delete $path(test1) 5085 set x "" 5086} -constraints {nonBlockFiles} -body { 5087 set f1 [open $path(test1) w] 5088 chan close $f1 5089 set f1 [open $path(test1) r] 5090 lappend x [chan configure $f1 -blocking] 5091 chan configure $f1 -blocking off 5092 lappend x [chan configure $f1 -blocking] 5093 lappend x [chan gets $f1] 5094 lappend x [chan read $f1 1000] 5095 lappend x [chan blocked $f1] 5096 lappend x [chan eof $f1] 5097} -cleanup { 5098 chan close $f1 5099} -result {1 0 {} {} 0 1} 5100test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup { 5101 file delete $path(pipe) 5102 set x "" 5103} -constraints stdio -body { 5104 set f1 [open $path(pipe) w] 5105 chan puts $f1 { 5106 chan gets stdin 5107 after 100 5108 chan puts hi 5109 chan gets stdin 5110 } 5111 chan close $f1 5112 set f1 [openpipe r+ $path(pipe)] 5113 chan configure $f1 -blocking off -buffering line 5114 lappend x [chan configure $f1 -blocking] 5115 lappend x [chan gets $f1] 5116 lappend x [chan blocked $f1] 5117 chan configure $f1 -blocking on 5118 chan puts $f1 hello 5119 chan configure $f1 -blocking off 5120 lappend x [chan gets $f1] 5121 lappend x [chan blocked $f1] 5122 chan configure $f1 -blocking on 5123 chan puts $f1 bye 5124 chan configure $f1 -blocking off 5125 lappend x [chan gets $f1] 5126 lappend x [chan blocked $f1] 5127 chan configure $f1 -blocking on 5128 lappend x [chan configure $f1 -blocking] 5129 lappend x [chan gets $f1] 5130 lappend x [chan blocked $f1] 5131 lappend x [chan eof $f1] 5132 lappend x [chan gets $f1] 5133 lappend x [chan eof $f1] 5134} -cleanup { 5135 chan close $f1 5136} -result {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} 5137test chan-io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} -setup { 5138 file delete $path(test1) 5139} -body { 5140 set f [open $path(test1) w] 5141 chan configure $f -buffersize -10 5142 chan configure $f -buffersize 5143} -cleanup { 5144 chan close $f 5145} -result 1 5146test chan-io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} -setup { 5147 file delete $path(test1) 5148} -body { 5149 set f [open $path(test1) w] 5150 chan configure $f -buffersize 10000000 5151 chan configure $f -buffersize 5152} -cleanup { 5153 chan close $f 5154} -result 1048576 5155test chan-io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} -setup { 5156 file delete $path(test1) 5157} -body { 5158 set f [open $path(test1) w] 5159 chan configure $f -buffersize 40000 5160 chan configure $f -buffersize 5161} -cleanup { 5162 chan close $f 5163} -result 40000 5164test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { 5165 file delete $path(test1) 5166} -body { 5167 set f [open $path(test1) w] 5168 chan configure $f -encoding {} 5169 chan puts -nonewline $f \xE7\x89\xA6 5170 chan close $f 5171 set f [open $path(test1) r] 5172 chan configure $f -encoding utf-8 5173 chan read $f 5174} -cleanup { 5175 chan close $f 5176} -result 牦 5177test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { 5178 file delete $path(test1) 5179} -body { 5180 set f [open $path(test1) w] 5181 chan configure $f -encoding binary 5182 chan puts -nonewline $f \xE7\x89\xA6 5183 chan close $f 5184 set f [open $path(test1) r] 5185 chan configure $f -encoding utf-8 5186 chan read $f 5187} -cleanup { 5188 chan close $f 5189} -result 牦 5190test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { 5191 file delete $path(test1) 5192 set f [open $path(test1) w] 5193} -body { 5194 chan configure $f -encoding foobar 5195} -returnCodes error -cleanup { 5196 chan close $f 5197} -result {unknown encoding "foobar"} 5198test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup { 5199 variable x {} 5200} -constraints {stdio fileevent} -body { 5201 set f [openpipe r+ $path(cat)] 5202 chan configure $f -encoding binary 5203 chan puts -nonewline $f "\xE7" 5204 chan flush $f 5205 chan configure $f -encoding utf-8 -blocking 0 5206 chan event $f readable [namespace code { lappend x [chan read $f] }] 5207 vwait [namespace which -variable x] 5208 after 300 [namespace code { lappend x timeout }] 5209 vwait [namespace which -variable x] 5210 chan configure $f -encoding utf-8 5211 vwait [namespace which -variable x] 5212 after 300 [namespace code { lappend x timeout }] 5213 vwait [namespace which -variable x] 5214 chan configure $f -encoding binary 5215 vwait [namespace which -variable x] 5216 after 300 [namespace code { lappend x timeout }] 5217 vwait [namespace which -variable x] 5218 return $x 5219} -cleanup { 5220 chan close $f 5221} -result "{} timeout {} timeout \xE7 timeout" 5222test chan-io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ 5223 -constraints {socket} -body { 5224 proc accept {s a p} {chan close $s} 5225 set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 5226 set port [lindex [chan configure $s1 -sockname] 2] 5227 set s2 [socket 127.0.0.1 $port] 5228 update 5229 chan configure $s2 -translation {auto lf} 5230 chan configure $s2 -translation 5231} -cleanup { 5232 chan close $s1 5233 chan close $s2 5234} -result {auto lf} 5235test chan-io-39.19 {Tcl_SetChannelOption, setting read mode independently} \ 5236 -constraints {socket} -body { 5237 proc accept {s a p} {chan close $s} 5238 set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 5239 set port [lindex [chan configure $s1 -sockname] 2] 5240 set s2 [socket 127.0.0.1 $port] 5241 update 5242 chan configure $s2 -translation {auto crlf} 5243 chan configure $s2 -translation 5244} -cleanup { 5245 chan close $s1 5246 chan close $s2 5247} -result {auto crlf} 5248test chan-io-39.20 {Tcl_SetChannelOption, setting read mode independently} \ 5249 -constraints {socket} -body { 5250 proc accept {s a p} {chan close $s} 5251 set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 5252 set port [lindex [chan configure $s1 -sockname] 2] 5253 set s2 [socket 127.0.0.1 $port] 5254 update 5255 chan configure $s2 -translation {auto cr} 5256 chan configure $s2 -translation 5257} -cleanup { 5258 chan close $s1 5259 chan close $s2 5260} -result {auto cr} 5261test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ 5262 -constraints {socket} -body { 5263 proc accept {s a p} {chan close $s} 5264 set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 5265 set port [lindex [chan configure $s1 -sockname] 2] 5266 set s2 [socket 127.0.0.1 $port] 5267 update 5268 chan configure $s2 -translation {auto auto} 5269 chan configure $s2 -translation 5270} -cleanup { 5271 chan close $s1 5272 chan close $s2 5273} -result {auto crlf} 5274test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { 5275 file delete $path(test1) 5276 set l "" 5277} -constraints {unix} -body { 5278 set f1 [open $path(test1) w+] 5279 lappend l [chan configure $f1 -eofchar] 5280 chan configure $f1 -eofchar {ON GO} 5281 lappend l [chan configure $f1 -eofchar] 5282 chan configure $f1 -eofchar D 5283 lappend l [chan configure $f1 -eofchar] 5284} -cleanup { 5285 chan close $f1 5286} -result {{{} {}} {O G} {D D}} 5287test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { 5288 file delete $path(test1) 5289 set l [list] 5290} -body { 5291 set f1 [open $path(test1) w+] 5292 chan configure $f1 -eofchar {ON GO} 5293 lappend l [chan configure $f1 -eofchar] 5294 chan configure $f1 -eofchar D 5295 lappend l [chan configure $f1 -eofchar] 5296 lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] 5297} -cleanup { 5298 chan close $f1 5299} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} 5300test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\ 5301 writeable, it should still have valid -eofchar and -translation options} -setup { 5302 set l [list] 5303} -body { 5304 set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 5305 lappend l [chan configure $sock -eofchar] \ 5306 [chan configure $sock -translation] 5307} -cleanup { 5308 chan close $sock 5309} -result {{{}} auto} 5310test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ 5311 writable so we can't change -eofchar or -translation} -setup { 5312 set l [list] 5313} -body { 5314 set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 5315 chan configure $sock -eofchar D -translation lf 5316 lappend l [chan configure $sock -eofchar] \ 5317 [chan configure $sock -translation] 5318} -cleanup { 5319 chan close $sock 5320} -result {{{}} auto} 5321 5322test chan-io-40.1 {POSIX open access modes: RDWR} -setup { 5323 file delete $path(test3) 5324} -body { 5325 set f [open $path(test3) w] 5326 chan puts $f xyzzy 5327 chan close $f 5328 set f [open $path(test3) RDWR] 5329 chan puts -nonewline $f "ab" 5330 chan seek $f 0 current 5331 set x [chan gets $f] 5332 chan close $f 5333 set f [open $path(test3) r] 5334 lappend x [chan gets $f] 5335} -cleanup { 5336 chan close $f 5337} -result {zzy abzzy} 5338test chan-io-40.2 {POSIX open access modes: CREAT} -setup { 5339 file delete $path(test3) 5340} -constraints {unix} -body { 5341 set f [open $path(test3) {WRONLY CREAT} 0o600] 5342 file stat $path(test3) stats 5343 set x [format 0o%03o [expr {$stats(mode) & 0o777}]] 5344 chan puts $f "line 1" 5345 chan close $f 5346 set f [open $path(test3) r] 5347 lappend x [chan gets $f] 5348} -cleanup { 5349 chan close $f 5350} -result {0o600 {line 1}} 5351test chan-io-40.3 {POSIX open access modes: CREAT} -setup { 5352 file delete $path(test3) 5353} -constraints {unix umask} -body { 5354 # This test only works if your umask is 2, like ouster's. 5355 chan close [open $path(test3) {WRONLY CREAT}] 5356 file stat $path(test3) stats 5357 format 0o%03o [expr {$stats(mode) & 0o777}] 5358} -result [format 0o%03o [expr {0o666 & ~ $umaskValue}]] 5359test chan-io-40.4 {POSIX open access modes: CREAT} -setup { 5360 file delete $path(test3) 5361} -body { 5362 set f [open $path(test3) w] 5363 chan configure $f -eofchar {} 5364 chan puts $f xyzzy 5365 chan close $f 5366 set f [open $path(test3) {WRONLY CREAT}] 5367 chan configure $f -eofchar {} 5368 chan puts -nonewline $f "ab" 5369 chan close $f 5370 set f [open $path(test3) r] 5371 chan gets $f 5372} -cleanup { 5373 chan close $f 5374} -result abzzy 5375test chan-io-40.5 {POSIX open access modes: APPEND} -setup { 5376 file delete $path(test3) 5377 set x "" 5378} -body { 5379 set f [open $path(test3) w] 5380 chan configure $f -translation lf -eofchar {} 5381 chan puts $f xyzzy 5382 chan close $f 5383 set f [open $path(test3) {WRONLY APPEND}] 5384 chan configure $f -translation lf 5385 chan puts $f "new line" 5386 chan seek $f 0 5387 chan puts $f "abc" 5388 chan close $f 5389 set f [open $path(test3) r] 5390 chan configure $f -translation lf 5391 chan seek $f 6 current 5392 lappend x [chan gets $f] 5393 lappend x [chan gets $f] 5394} -cleanup { 5395 chan close $f 5396} -result {{new line} abc} 5397test chan-io-40.6 {POSIX open access modes: EXCL} -match regexp -setup { 5398 file delete $path(test3) 5399} -body { 5400 set f [open $path(test3) w] 5401 chan puts $f xyzzy 5402 chan close $f 5403 open $path(test3) {WRONLY CREAT EXCL} 5404} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists} 5405test chan-io-40.7 {POSIX open access modes: EXCL} -setup { 5406 file delete $path(test3) 5407} -body { 5408 set f [open $path(test3) {WRONLY CREAT EXCL}] 5409 chan configure $f -eofchar {} 5410 chan puts $f "A test line" 5411 chan close $f 5412 viewFile test3 5413} -result {A test line} 5414test chan-io-40.8 {POSIX open access modes: TRUNC} -setup { 5415 file delete $path(test3) 5416} -body { 5417 set f [open $path(test3) w] 5418 chan puts $f xyzzy 5419 chan close $f 5420 set f [open $path(test3) {WRONLY TRUNC}] 5421 chan puts $f abc 5422 chan close $f 5423 set f [open $path(test3) r] 5424 chan gets $f 5425} -cleanup { 5426 chan close $f 5427} -result abc 5428test chan-io-40.9 {POSIX open access modes: NONBLOCK} -setup { 5429 file delete $path(test3) 5430} -constraints {nonPortable unix} -body { 5431 set f [open $path(test3) {WRONLY NONBLOCK CREAT}] 5432 chan puts $f "NONBLOCK test" 5433 chan close $f 5434 set f [open $path(test3) r] 5435 chan gets $f 5436} -cleanup { 5437 chan close $f 5438} -result {NONBLOCK test} 5439test chan-io-40.10 {POSIX open access modes: RDONLY} -body { 5440 set f [open $path(test1) w] 5441 chan puts $f "two lines: this one" 5442 chan puts $f "and this" 5443 chan close $f 5444 set f [open $path(test1) RDONLY] 5445 list [chan gets $f] [catch {chan puts $f Test} msg] $msg 5446} -cleanup { 5447 chan close $f 5448} -match glob -result {{two lines: this one} 1 {channel "*" wasn't opened for writing}} 5449test chan-io-40.11 {POSIX open access modes: RDONLY} -match regexp -body { 5450 file delete $path(test3) 5451 open $path(test3) RDONLY 5452} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} 5453test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body { 5454 file delete $path(test3) 5455 open $path(test3) WRONLY 5456} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} 5457test chan-io-40.13 {POSIX open access modes: WRONLY} -body { 5458 makeFile xyzzy test3 5459 set f [open $path(test3) WRONLY] 5460 chan configure $f -eofchar {} 5461 chan puts -nonewline $f "ab" 5462 chan seek $f 0 current 5463 set x [list [catch {chan gets $f} msg] $msg] 5464 chan close $f 5465 lappend x [viewFile test3] 5466} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy} 5467test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body { 5468 file delete $path(test3) 5469 open $path(test3) RDWR 5470} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} 5471test chan-io-40.15 {POSIX open access modes: RDWR} { 5472 makeFile xyzzy test3 5473 set f [open $path(test3) RDWR] 5474 chan puts -nonewline $f "ab" 5475 chan seek $f 0 current 5476 set x [chan gets $f] 5477 chan close $f 5478 lappend x [viewFile test3] 5479} {zzy abzzy} 5480test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup { 5481 makeFile {Some text} _test_ ~ 5482} -body { 5483 file exists [file join $::env(HOME) _test_] 5484} -cleanup { 5485 removeFile _test_ ~ 5486} -result 1 5487test chan-io-40.17 {tilde substitution in open} -setup { 5488 set home $::env(HOME) 5489} -body { 5490 unset ::env(HOME) 5491 open ~/foo 5492} -returnCodes error -cleanup { 5493 set ::env(HOME) $home 5494} -result {couldn't find HOME environment variable to expand path} 5495 5496test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body { 5497 chan event foo 5498} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"} 5499test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body { 5500 chan event foo bar baz q 5501} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"} 5502test chan-io-41.3 {Tcl_FileeventCmd: errors} -constraints fileevent -body { 5503 chan event gorp readable 5504} -returnCodes error -result {can not find channel named "gorp"} 5505test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body { 5506 chan event gorp writable 5507} -returnCodes error -result {can not find channel named "gorp"} 5508test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body { 5509 chan event gorp who-knows 5510} -returnCodes error -result {bad event name "who-knows": must be readable or writable} 5511 5512# 5513# Test chan event on a file 5514# 5515 5516set path(foo) [makeFile {} foo] 5517set f [open $path(foo) w+] 5518 5519test chan-io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} { 5520 list [chan event $f readable] [chan event $f writable] 5521} {{} {}} 5522test chan-io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} { 5523 set result {} 5524 chan event $f r "first script" 5525 lappend result [chan event $f readable] 5526 chan event $f r "new script" 5527 lappend result [chan event $f readable] 5528 chan event $f r "yet another" 5529 lappend result [chan event $f readable] 5530 chan event $f r "" 5531 lappend result [chan event $f readable] 5532} {{first script} {new script} {yet another} {}} 5533test chan-io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} { 5534 set result {} 5535 chan event $f r "first scr\x00ipt" 5536 lappend result [string length [chan event $f readable]] 5537 chan event $f r "new scr\x00ipt" 5538 lappend result [string length [chan event $f readable]] 5539 chan event $f r "yet ano\x00ther" 5540 lappend result [string length [chan event $f readable]] 5541 chan event $f r "" 5542 lappend result [chan event $f readable] 5543} {13 11 12 {}} 5544 5545test chan-io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} { 5546 set result {} 5547 chan event $f readable "script 1" 5548 lappend result [chan event $f readable] [chan event $f writable] 5549 chan event $f writable "write script" 5550 lappend result [chan event $f readable] [chan event $f writable] 5551 chan event $f readable {} 5552 lappend result [chan event $f readable] [chan event $f writable] 5553 chan event $f writable {} 5554 lappend result [chan event $f readable] [chan event $f writable] 5555} {{script 1} {} {script 1} {write script} {} {write script} {} {}} 5556test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { 5557 set f2 [open "|[list cat -u]" r+] 5558 set f3 [open "|[list cat -u]" r+] 5559 set result {} 5560} -constraints {stdio unixExecs fileevent} -body { 5561 lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] 5562 chan event $f r "chan read f" 5563 chan event $f2 r "chan read f2" 5564 chan event $f3 r "chan read f3" 5565 lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] 5566 chan event $f2 r {} 5567 lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] 5568 chan event $f3 r {} 5569 lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] 5570 chan event $f r {} 5571 lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] 5572} -cleanup { 5573 catch {chan close $f2} 5574 catch {chan close $f3} 5575} -result {{} {} {} {chan read f} {chan read f2} {chan read f3} {chan read f} {} {chan read f3} {chan read f} {} {} {} {} {}} 5576 5577test chan-io-44.1 {FileEventProc procedure: normal read event} -setup { 5578 set f2 [open "|[list cat -u]" r+] 5579 set f3 [open "|[list cat -u]" r+] 5580} -constraints {stdio unixExecs fileevent} -body { 5581 chan event $f2 readable [namespace code { 5582 set x [chan gets $f2]; chan event $f2 readable {} 5583 }] 5584 chan puts $f2 text; chan flush $f2 5585 variable x initial 5586 vwait [namespace which -variable x] 5587 return $x 5588} -cleanup { 5589 catch {chan close $f2} 5590 catch {chan close $f3} 5591} -result {text} 5592test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { 5593 set f2 [open "|[list cat -u]" r+] 5594 set f3 [open "|[list cat -u]" r+] 5595 proc myHandler {msg options} { 5596 variable x $msg 5597 } 5598 set handler [interp bgerror {}] 5599 interp bgerror {} [namespace which myHandler] 5600} -constraints {stdio unixExecs fileevent} -body { 5601 chan event $f2 readable {error bogus} 5602 chan puts $f2 text; chan flush $f2 5603 variable x initial 5604 vwait [namespace which -variable x] 5605 list $x [chan event $f2 readable] 5606} -cleanup { 5607 interp bgerror {} $handler 5608 catch {chan close $f2} 5609 catch {chan close $f3} 5610} -result {bogus {}} 5611test chan-io-44.3 {FileEventProc procedure: normal write event} -setup { 5612 set f2 [open "|[list cat -u]" r+] 5613 set f3 [open "|[list cat -u]" r+] 5614} -constraints {stdio unixExecs fileevent} -body { 5615 chan event $f2 writable [namespace code { 5616 lappend x "triggered" 5617 incr count -1 5618 if {$count <= 0} { 5619 chan event $f2 writable {} 5620 } 5621 }] 5622 variable x initial 5623 set count 3 5624 vwait [namespace which -variable x] 5625 vwait [namespace which -variable x] 5626 vwait [namespace which -variable x] 5627 return $x 5628} -cleanup { 5629 catch {chan close $f2} 5630 catch {chan close $f3} 5631} -result {initial triggered triggered triggered} 5632test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { 5633 set f2 [open "|[list cat -u]" r+] 5634 set f3 [open "|[list cat -u]" r+] 5635 proc myHandler {msg options} { 5636 variable x $msg 5637 } 5638 set handler [interp bgerror {}] 5639 interp bgerror {} [namespace which myHandler] 5640} -constraints {stdio unixExecs fileevent} -body { 5641 chan event $f2 writable {error bad-write} 5642 variable x initial 5643 vwait [namespace which -variable x] 5644 list $x [chan event $f2 writable] 5645} -cleanup { 5646 interp bgerror {} $handler 5647 catch {chan close $f2} 5648 catch {chan close $f3} 5649} -result {bad-write {}} 5650test chan-io-44.5 {FileEventProc procedure: end of file} -constraints { 5651 stdio unixExecs fileevent 5652} -body { 5653 set f4 [openpipe r $path(cat) << foo] 5654 chan event $f4 readable [namespace code { 5655 if {[chan gets $f4 line] < 0} { 5656 lappend x eof 5657 chan event $f4 readable {} 5658 } else { 5659 lappend x $line 5660 } 5661 }] 5662 variable x initial 5663 vwait [namespace which -variable x] 5664 vwait [namespace which -variable x] 5665 set x 5666} -cleanup { 5667 chan close $f4 5668} -result {initial foo eof} 5669 5670chan close $f 5671makeFile "foo bar" foo 5672 5673test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} { 5674 set f [open $path(foo) r] 5675 chan event $f readable [namespace code { 5676 lappend x "binding triggered: \"[chan gets $f]\"" 5677 chan event $f readable {} 5678 }] 5679 chan close $f 5680 set x initial 5681 after 100 [namespace code { 5682 set y done 5683 }] 5684 variable y 5685 vwait [namespace which -variable y] 5686 set x 5687} {initial} 5688test chan-io-45.2 {DeleteFileEvent, cleanup on chan close} {fileevent} { 5689 set f [open $path(foo) r] 5690 set f2 [open $path(foo) r] 5691 chan event $f readable [namespace code { 5692 lappend x "f triggered: \"[chan gets $f]\"" 5693 chan event $f readable {} 5694 }] 5695 chan event $f2 readable [namespace code { 5696 lappend x "f2 triggered: \"[chan gets $f2]\"" 5697 chan event $f2 readable {} 5698 }] 5699 chan close $f 5700 variable x initial 5701 vwait [namespace which -variable x] 5702 chan close $f2 5703 set x 5704} {initial {f2 triggered: "foo bar"}} 5705test chan-io-45.3 {DeleteFileEvent, cleanup on chan close} {fileevent} { 5706 set f [open $path(foo) r] 5707 set f2 [open $path(foo) r] 5708 set f3 [open $path(foo) r] 5709 chan event $f readable {f script} 5710 chan event $f2 readable {f2 script} 5711 chan event $f3 readable {f3 script} 5712 set x {} 5713 chan close $f2 5714 lappend x [catch {chan event $f readable} msg] $msg \ 5715 [catch {chan event $f2 readable}] \ 5716 [catch {chan event $f3 readable} msg] $msg 5717 chan close $f3 5718 lappend x [catch {chan event $f readable} msg] $msg \ 5719 [catch {chan event $f2 readable}] \ 5720 [catch {chan event $f3 readable}] 5721 chan close $f 5722 lappend x [catch {chan event $f readable}] \ 5723 [catch {chan event $f2 readable}] \ 5724 [catch {chan event $f3 readable}] 5725} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} 5726 5727# Execute these tests only if the "testfevent" command is present. 5728 5729test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { 5730 testfevent create 5731 set script "set f \[[list open $path(foo) r]]\n" 5732 append script { 5733 set x "no event" 5734 chan event $f readable [namespace code { 5735 set x "f triggered: [chan gets $f]" 5736 chan event $f readable {} 5737 }] 5738 } 5739 set timer [after 10 lappend x timeout] 5740 testfevent cmd $script 5741 vwait x 5742 after cancel $timer 5743 testfevent cmd {chan close $f} 5744 list [testfevent cmd {set x}] [testfevent cmd {info commands after}] 5745} {{f triggered: foo bar} after} 5746test chan-io-46.2 {Tcl event loop vs multiple interpreters} testfevent { 5747 testfevent create 5748 testfevent cmd { 5749 variable x 0 5750 after 100 {set x triggered} 5751 vwait [namespace which -variable x] 5752 set x 5753 } 5754} {triggered} 5755test chan-io-46.3 {Tcl event loop vs multiple interpreters} testfevent { 5756 testfevent create 5757 testfevent cmd { 5758 set x 0 5759 after 10 {lappend x timer} 5760 after 30 5761 set result $x 5762 update idletasks 5763 lappend result $x 5764 update 5765 lappend result $x 5766 } 5767} {0 0 {0 timer}} 5768 5769test chan-io-47.1 {chan event vs multiple interpreters} -setup { 5770 set f [open $path(foo) r] 5771 set f2 [open $path(foo) r] 5772 set f3 [open $path(foo) r] 5773 set x {} 5774} -constraints {testfevent fileevent} -body { 5775 chan event $f readable {script 1} 5776 testfevent create 5777 testfevent share $f2 5778 testfevent cmd "chan event $f2 readable {script 2}" 5779 chan event $f3 readable {sript 3} 5780 lappend x [chan event $f2 readable] 5781 testfevent delete 5782 lappend x [chan event $f readable] [chan event $f2 readable] \ 5783 [chan event $f3 readable] 5784} -cleanup { 5785 chan close $f 5786 chan close $f2 5787 chan close $f3 5788} -result {{} {script 1} {} {sript 3}} 5789test chan-io-47.2 {deleting chan event on interpreter delete} -setup { 5790 set f [open $path(foo) r] 5791 set f2 [open $path(foo) r] 5792 set f3 [open $path(foo) r] 5793 set f4 [open $path(foo) r] 5794} -constraints {testfevent fileevent} -body { 5795 chan event $f readable {script 1} 5796 testfevent create 5797 testfevent share $f2 5798 testfevent share $f3 5799 testfevent cmd "chan event $f2 readable {script 2} 5800 chan event $f3 readable {script 3}" 5801 chan event $f4 readable {script 4} 5802 testfevent delete 5803 list [chan event $f readable] [chan event $f2 readable] \ 5804 [chan event $f3 readable] [chan event $f4 readable] 5805} -cleanup { 5806 chan close $f 5807 chan close $f2 5808 chan close $f3 5809 chan close $f4 5810} -result {{script 1} {} {} {script 4}} 5811test chan-io-47.3 {deleting chan event on interpreter delete} -setup { 5812 set f [open $path(foo) r] 5813 set f2 [open $path(foo) r] 5814 set f3 [open $path(foo) r] 5815 set f4 [open $path(foo) r] 5816} -constraints {testfevent fileevent} -body { 5817 testfevent create 5818 testfevent share $f3 5819 testfevent share $f4 5820 chan event $f readable {script 1} 5821 chan event $f2 readable {script 2} 5822 testfevent cmd "chan event $f3 readable {script 3} 5823 chan event $f4 readable {script 4}" 5824 testfevent delete 5825 list [chan event $f readable] [chan event $f2 readable] \ 5826 [chan event $f3 readable] [chan event $f4 readable] 5827} -cleanup { 5828 chan close $f 5829 chan close $f2 5830 chan close $f3 5831 chan close $f4 5832} -result {{script 1} {script 2} {} {}} 5833test chan-io-47.4 {file events on shared files and multiple interpreters} -setup { 5834 set f [open $path(foo) r] 5835 set f2 [open $path(foo) r] 5836} -constraints {testfevent fileevent} -body { 5837 testfevent create 5838 testfevent share $f 5839 testfevent cmd "chan event $f readable {script 1}" 5840 chan event $f readable {script 2} 5841 chan event $f2 readable {script 3} 5842 list [chan event $f2 readable] [testfevent cmd "chan event $f readable"] \ 5843 [chan event $f readable] 5844} -cleanup { 5845 testfevent delete 5846 chan close $f 5847 chan close $f2 5848} -result {{script 3} {script 1} {script 2}} 5849test chan-io-47.5 {file events on shared files, deleting file events} -setup { 5850 set f [open $path(foo) r] 5851} -body { 5852 testfevent create 5853 testfevent share $f 5854 testfevent cmd "chan event $f readable {script 1}" 5855 chan event $f readable {script 2} 5856 testfevent cmd "chan event $f readable {}" 5857 list [testfevent cmd "chan event $f readable"] [chan event $f readable] 5858} -constraints {testfevent fileevent} -cleanup { 5859 testfevent delete 5860 chan close $f 5861} -result {{} {script 2}} 5862test chan-io-47.6 {file events on shared files, deleting file events} -setup { 5863 set f [open $path(foo) r] 5864} -body { 5865 testfevent create 5866 testfevent share $f 5867 testfevent cmd "chan event $f readable {script 1}" 5868 chan event $f readable {script 2} 5869 chan event $f readable {} 5870 list [testfevent cmd "chan event $f readable"] [chan event $f readable] 5871} -constraints {testfevent fileevent} -cleanup { 5872 testfevent delete 5873 chan close $f 5874} -result {{script 1} {}} 5875unset path(foo) 5876removeFile foo 5877 5878set path(bar) [makeFile {} bar] 5879 5880test chan-io-48.1 {testing readability conditions} {fileevent} { 5881 set f [open $path(bar) w] 5882 chan puts $f abcdefg 5883 chan puts $f abcdefg 5884 chan puts $f abcdefg 5885 chan puts $f abcdefg 5886 chan puts $f abcdefg 5887 chan close $f 5888 set f [open $path(bar) r] 5889 chan event $f readable [namespace code { 5890 lappend l called 5891 if {[chan eof $f]} { 5892 chan close $f 5893 set x done 5894 } else { 5895 chan gets $f 5896 } 5897 }] 5898 set l "" 5899 variable x not_done 5900 vwait [namespace which -variable x] 5901 list $x $l 5902} {done {called called called called called called called}} 5903test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { 5904 set f [open $path(bar) w] 5905 chan puts $f abcdefg 5906 chan puts $f abcdefg 5907 chan puts $f abcdefg 5908 chan puts $f abcdefg 5909 chan puts $f abcdefg 5910 chan close $f 5911 set f [open $path(bar) r] 5912 chan event $f readable [namespace code { 5913 lappend l called 5914 if {[chan eof $f]} { 5915 chan close $f 5916 set x done 5917 } else { 5918 chan gets $f 5919 } 5920 }] 5921 chan configure $f -blocking off 5922 set l "" 5923 variable x not_done 5924 vwait [namespace which -variable x] 5925 list $x $l 5926} {done {called called called called called called called}} 5927set path(my_script) [makeFile {} my_script] 5928test chan-io-48.3 {testing readability conditions} -setup { 5929 set l "" 5930} -constraints {stdio unix nonBlockFiles fileevent} -body { 5931 set f [open $path(bar) w] 5932 chan puts $f abcdefg 5933 chan puts $f abcdefg 5934 chan puts $f abcdefg 5935 chan puts $f abcdefg 5936 chan puts $f abcdefg 5937 chan close $f 5938 set f [open $path(my_script) w] 5939 chan puts $f { 5940 proc copy_slowly {f} { 5941 while {![chan eof $f]} { 5942 chan puts [chan gets $f] 5943 after 200 5944 } 5945 chan close $f 5946 } 5947 } 5948 chan close $f 5949 set f [openpipe] 5950 chan event $f readable [namespace code { 5951 if {[chan eof $f]} { 5952 set x done 5953 } else { 5954 chan gets $f 5955 lappend l [chan blocked $f] 5956 chan gets $f 5957 lappend l [chan blocked $f] 5958 } 5959 }] 5960 chan configure $f -buffering line 5961 chan configure $f -blocking off 5962 variable x not_done 5963 chan puts $f [list source $path(my_script)] 5964 chan puts $f "set f \[[list open $path(bar) r]]" 5965 chan puts $f {copy_slowly $f} 5966 chan puts $f {exit} 5967 vwait [namespace which -variable x] 5968 list $x $l 5969} -cleanup { 5970 chan close $f 5971} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} 5972unset path(bar) 5973removeFile bar 5974 5975test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup { 5976 file delete $path(test1) 5977 set c 0 5978 set l "" 5979} -constraints {fileevent} -body { 5980 set f [open $path(test1) w] 5981 chan configure $f -translation lf 5982 chan puts -nonewline $f [format "abc\ndef\n%c" 26] 5983 chan close $f 5984 set f [open $path(test1) r] 5985 chan configure $f -translation auto -eofchar \x1A 5986 chan event $f readable [namespace code { 5987 if {[chan eof $f]} { 5988 set x done 5989 chan close $f 5990 } else { 5991 lappend l [chan gets $f] 5992 incr c 5993 } 5994 }] 5995 variable x 5996 vwait [namespace which -variable x] 5997 list $c $l 5998} -result {3 {abc def {}}} 5999test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} -setup { 6000 file delete $path(test1) 6001 set c 0 6002 set l "" 6003} -constraints {fileevent} -body { 6004 set f [open $path(test1) w] 6005 chan configure $f -translation lf 6006 chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] 6007 chan close $f 6008 set f [open $path(test1) r] 6009 chan configure $f -translation auto -eofchar \x1A 6010 chan event $f readable [namespace code { 6011 if {[chan eof $f]} { 6012 set x done 6013 chan close $f 6014 } else { 6015 lappend l [chan gets $f] 6016 incr c 6017 } 6018 }] 6019 variable x 6020 vwait [namespace which -variable x] 6021 list $c $l 6022} -result {3 {abc def {}}} 6023test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode} -setup { 6024 file delete $path(test1) 6025 set c 0 6026 set l "" 6027} -constraints {fileevent} -body { 6028 set f [open $path(test1) w] 6029 chan configure $f -translation cr 6030 chan puts -nonewline $f [format "abc\ndef\n%c" 26] 6031 chan close $f 6032 set f [open $path(test1) r] 6033 chan configure $f -translation auto -eofchar \x1A 6034 chan event $f readable [namespace code { 6035 if {[chan eof $f]} { 6036 set x done 6037 chan close $f 6038 } else { 6039 lappend l [chan gets $f] 6040 incr c 6041 } 6042 }] 6043 variable x 6044 vwait [namespace which -variable x] 6045 list $c $l 6046} -result {3 {abc def {}}} 6047test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} -setup { 6048 file delete $path(test1) 6049 set c 0 6050 set l "" 6051} -constraints {fileevent} -body { 6052 set f [open $path(test1) w] 6053 chan configure $f -translation cr 6054 chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] 6055 chan close $f 6056 set f [open $path(test1) r] 6057 chan configure $f -translation auto -eofchar \x1A 6058 chan event $f readable [namespace code { 6059 if {[chan eof $f]} { 6060 set x done 6061 chan close $f 6062 } else { 6063 lappend l [chan gets $f] 6064 incr c 6065 } 6066 }] 6067 variable x 6068 vwait [namespace which -variable x] 6069 list $c $l 6070} -result {3 {abc def {}}} 6071test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} -setup { 6072 file delete $path(test1) 6073 set c 0 6074 set l "" 6075} -constraints {fileevent} -body { 6076 set f [open $path(test1) w] 6077 chan configure $f -translation crlf 6078 chan puts -nonewline $f [format "abc\ndef\n%c" 26] 6079 chan close $f 6080 set f [open $path(test1) r] 6081 chan configure $f -translation auto -eofchar \x1A 6082 chan event $f readable [namespace code { 6083 if {[chan eof $f]} { 6084 set x done 6085 chan close $f 6086 } else { 6087 lappend l [chan gets $f] 6088 incr c 6089 } 6090 }] 6091 variable x 6092 vwait [namespace which -variable x] 6093 list $c $l 6094} -result {3 {abc def {}}} 6095test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} -setup { 6096 file delete $path(test1) 6097 set c 0 6098 set l "" 6099} -constraints {fileevent} -body { 6100 set f [open $path(test1) w] 6101 chan configure $f -translation crlf 6102 chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] 6103 chan close $f 6104 set f [open $path(test1) r] 6105 chan configure $f -translation auto -eofchar \x1A 6106 chan event $f readable [namespace code { 6107 if {[chan eof $f]} { 6108 set x done 6109 chan close $f 6110 } else { 6111 lappend l [chan gets $f] 6112 incr c 6113 } 6114 }] 6115 variable x 6116 vwait [namespace which -variable x] 6117 list $c $l 6118} -result {3 {abc def {}}} 6119test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} -setup { 6120 file delete $path(test1) 6121 set c 0 6122 set l "" 6123} -constraints {fileevent} -body { 6124 set f [open $path(test1) w] 6125 chan configure $f -translation lf 6126 chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] 6127 chan close $f 6128 set f [open $path(test1) r] 6129 chan configure $f -translation lf -eofchar \x1A 6130 chan event $f readable [namespace code { 6131 if {[chan eof $f]} { 6132 set x done 6133 chan close $f 6134 } else { 6135 lappend l [chan gets $f] 6136 incr c 6137 } 6138 }] 6139 variable x 6140 vwait [namespace which -variable x] 6141 list $c $l 6142} -result {3 {abc def {}}} 6143test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} -setup { 6144 file delete $path(test1) 6145 set c 0 6146 set l "" 6147} -constraints {fileevent} -body { 6148 set f [open $path(test1) w] 6149 chan configure $f -translation lf 6150 chan puts -nonewline $f [format "abc\ndef\n%c" 26] 6151 chan close $f 6152 set f [open $path(test1) r] 6153 chan configure $f -translation lf -eofchar \x1A 6154 chan event $f readable [namespace code { 6155 if {[chan eof $f]} { 6156 set x done 6157 chan close $f 6158 } else { 6159 lappend l [chan gets $f] 6160 incr c 6161 } 6162 }] 6163 variable x 6164 vwait [namespace which -variable x] 6165 list $c $l 6166} -result {3 {abc def {}}} 6167test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} -setup { 6168 file delete $path(test1) 6169 set c 0 6170 set l "" 6171} -constraints {fileevent} -body { 6172 set f [open $path(test1) w] 6173 chan configure $f -translation cr 6174 chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] 6175 chan close $f 6176 set f [open $path(test1) r] 6177 chan configure $f -translation cr -eofchar \x1A 6178 chan event $f readable [namespace code { 6179 if {[chan eof $f]} { 6180 set x done 6181 chan close $f 6182 } else { 6183 lappend l [chan gets $f] 6184 incr c 6185 } 6186 }] 6187 variable x 6188 vwait [namespace which -variable x] 6189 list $c $l 6190} -result {3 {abc def {}}} 6191test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} -setup { 6192 file delete $path(test1) 6193 set c 0 6194 set l "" 6195} -constraints {fileevent} -body { 6196 set f [open $path(test1) w] 6197 chan configure $f -translation cr 6198 chan puts -nonewline $f [format "abc\ndef\n%c" 26] 6199 chan close $f 6200 set f [open $path(test1) r] 6201 chan configure $f -translation cr -eofchar \x1A 6202 chan event $f readable [namespace code { 6203 if {[chan eof $f]} { 6204 set x done 6205 chan close $f 6206 } else { 6207 lappend l [chan gets $f] 6208 incr c 6209 } 6210 }] 6211 variable x 6212 vwait [namespace which -variable x] 6213 list $c $l 6214} -result {3 {abc def {}}} 6215test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} -setup { 6216 file delete $path(test1) 6217 set c 0 6218 set l "" 6219} -constraints {fileevent} -body { 6220 set f [open $path(test1) w] 6221 chan configure $f -translation crlf 6222 chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] 6223 chan close $f 6224 set f [open $path(test1) r] 6225 chan configure $f -translation crlf -eofchar \x1A 6226 chan event $f readable [namespace code { 6227 if {[chan eof $f]} { 6228 set x done 6229 chan close $f 6230 } else { 6231 lappend l [chan gets $f] 6232 incr c 6233 } 6234 }] 6235 variable x 6236 vwait [namespace which -variable x] 6237 list $c $l 6238} -result {3 {abc def {}}} 6239test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} -setup { 6240 file delete $path(test1) 6241 set c 0 6242 set l "" 6243} -constraints {fileevent} -body { 6244 set f [open $path(test1) w] 6245 chan configure $f -translation crlf 6246 chan puts -nonewline $f [format "abc\ndef\n%c" 26] 6247 chan close $f 6248 set f [open $path(test1) r] 6249 chan configure $f -translation crlf -eofchar \x1A 6250 chan event $f readable [namespace code { 6251 if {[chan eof $f]} { 6252 set x done 6253 chan close $f 6254 } else { 6255 lappend l [chan gets $f] 6256 incr c 6257 } 6258 }] 6259 variable x 6260 vwait [namespace which -variable x] 6261 list $c $l 6262} -result {3 {abc def {}}} 6263 6264test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} -setup { 6265 file delete $path(test1) 6266 set l "" 6267} -body { 6268 set f [open $path(test1) w] 6269 chan configure $f -translation lf 6270 chan puts -nonewline $f "a\rb\rc\r\n" 6271 chan close $f 6272 set f [open $path(test1) r] 6273 lappend l [file size $path(test1)] 6274 chan configure $f -translation crlf 6275 lappend l [chan read $f 1] 6276 lappend l [chan tell $f] 6277 lappend l [chan read $f 1] 6278 lappend l [chan tell $f] 6279 lappend l [chan read $f 1] 6280 lappend l [chan tell $f] 6281 lappend l [chan read $f 1] 6282 lappend l [chan tell $f] 6283 lappend l [chan read $f 1] 6284 lappend l [chan tell $f] 6285 lappend l [chan read $f 1] 6286 lappend l [chan tell $f] 6287 lappend l [chan eof $f] 6288 lappend l [chan read $f 1] 6289 lappend l [chan eof $f] 6290} -cleanup { 6291 chan close $f 6292} -result "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { 6293} 7 0 {} 1" 6294test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} -setup { 6295 file delete $path(test1) 6296 set l "" 6297} -body { 6298 set f [open $path(test1) w] 6299 chan configure $f -translation lf 6300 chan puts -nonewline $f "a\rb\rc\r\n" 6301 chan close $f 6302 set f [open $path(test1) r] 6303 lappend l [file size $path(test1)] 6304 chan configure $f -translation crlf 6305 lappend l [chan read $f 2] 6306 lappend l [chan tell $f] 6307 lappend l [chan read $f 2] 6308 lappend l [chan tell $f] 6309 lappend l [chan read $f 2] 6310 lappend l [chan tell $f] 6311 lappend l [chan eof $f] 6312 lappend l [chan read $f 2] 6313 lappend l [chan tell $f] 6314 lappend l [chan eof $f] 6315} -cleanup { 6316 chan close $f 6317} -result "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" 6318test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} -setup { 6319 file delete $path(test1) 6320 set l "" 6321} -body { 6322 set f [open $path(test1) w] 6323 chan configure $f -translation lf 6324 chan puts -nonewline $f "a\rb\rc\r\n" 6325 chan close $f 6326 set f [open $path(test1) r] 6327 lappend l [file size $path(test1)] 6328 chan configure $f -translation crlf 6329 lappend l [chan read $f 3] 6330 lappend l [chan tell $f] 6331 lappend l [chan read $f 3] 6332 lappend l [chan tell $f] 6333 lappend l [chan eof $f] 6334 lappend l [chan read $f 3] 6335 lappend l [chan tell $f] 6336 lappend l [chan eof $f] 6337} -cleanup { 6338 chan close $f 6339} -result "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" 6340test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} -setup { 6341 file delete $path(test1) 6342 set l "" 6343} -body { 6344 set f [open $path(test1) w] 6345 chan configure $f -translation lf 6346 chan puts -nonewline $f "a\rb\rc\r\n" 6347 chan close $f 6348 set f [open $path(test1) r] 6349 lappend l [file size $path(test1)] 6350 chan configure $f -translation crlf 6351 lappend l [chan read $f 3] 6352 lappend l [chan tell $f] 6353 lappend l [chan gets $f] 6354 lappend l [chan tell $f] 6355 lappend l [chan eof $f] 6356 lappend l [chan gets $f] 6357 lappend l [chan tell $f] 6358 lappend l [chan eof $f] 6359} -cleanup { 6360 chan close $f 6361} -result "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" 6362test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup { 6363 file delete $path(test1) 6364 set l "" 6365} -body { 6366 set f [open $path(test1) w] 6367 chan configure $f -translation lf 6368 chan puts -nonewline $f "a\rb\rc\r\n" 6369 chan close $f 6370 set f [open $path(test1) r] 6371 lappend l [file size $path(test1)] 6372 chan configure $f -translation crlf 6373 lappend l [set x [chan gets $f]] 6374 lappend l [chan tell $f] 6375 lappend l [chan gets $f] 6376 lappend l [chan tell $f] 6377 lappend l [chan eof $f] 6378} -cleanup { 6379 chan close $f 6380} -result [list 7 a\rb\rc 7 {} 7 1] 6381 6382test chan-io-50.1 {testing handler deletion} -setup { 6383 file delete $path(test1) 6384} -constraints testchannelevent -body { 6385 set f [open $path(test1) w] 6386 chan close $f 6387 set f [open $path(test1) r] 6388 variable z not_called 6389 set timer [after 50 lappend z timeout] 6390 testservicemode 0 6391 testchannelevent $f add readable [namespace code { 6392 variable z called 6393 testchannelevent $f delete 0 6394 }] 6395 testservicemode 1 6396 vwait z 6397 after cancel $timer 6398 set z 6399} -cleanup { 6400 chan close $f 6401} -result called 6402test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { 6403 file delete $path(test1) 6404 chan close [open $path(test1) w] 6405 set z "" 6406} -constraints {testchannelevent testservicemode} -body { 6407 proc delhandler {f i} { 6408 variable z 6409 lappend z "called delhandler $f $i" 6410 testchannelevent $f delete 0 6411 } 6412 set z "" 6413 set timer [after 50 lappend z timeout] 6414 testservicemode 0 6415 set f [open $path(test1) r] 6416 testchannelevent $f add readable [namespace code [list delhandler $f 1]] 6417 testchannelevent $f add readable [namespace code [list delhandler $f 0]] 6418 testservicemode 1 6419 vwait z 6420 after cancel $timer 6421 string equal $z \ 6422 [list [list called delhandler $f 0] [list called delhandler $f 1]] 6423} -cleanup { 6424 chan close $f 6425} -result 1 6426test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { 6427 file delete $path(test1) 6428 chan close [open $path(test1) w] 6429} -constraints {testchannelevent testservicemode} -body { 6430 proc notcalled {f i} { 6431 variable z 6432 lappend z "notcalled was called!! $f $i" 6433 } 6434 proc delhandler {f i} { 6435 variable z 6436 testchannelevent $f delete 1 6437 lappend z "delhandler $f $i called" 6438 testchannelevent $f delete 0 6439 lappend z "delhandler $f $i deleted myself" 6440 } 6441 set z "" 6442 set timer [after 50 lappend z timeout] 6443 testservicemode 0 6444 set f [open $path(test1) r] 6445 testchannelevent $f add readable [namespace code [list notcalled $f 1]] 6446 testchannelevent $f add readable [namespace code [list delhandler $f 0]] 6447 testservicemode 1 6448 vwait z 6449 after cancel $timer 6450 string equal $z \ 6451 [list [list delhandler $f 0 called] \ 6452 [list delhandler $f 0 deleted myself]] 6453} -cleanup { 6454 chan close $f 6455} -result 1 6456test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { 6457 file delete $path(test1) 6458 set f [open $path(test1) w] 6459 chan close $f 6460} -constraints testchannelevent -body { 6461 set f [open $path(test1) r] 6462 testchannelevent $f add readable [namespace code { 6463 if {$u eq "recursive"} { 6464 testchannelevent $f delete 0 6465 lappend z "delrecursive deleting recursive" 6466 } else { 6467 lappend z "delrecursive calling recursive" 6468 set u recursive 6469 update 6470 } 6471 }] 6472 variable u toplevel 6473 variable z "" 6474 set timer [after 50 lappend z timeout] 6475 vwait z 6476 after cancel $timer 6477 set z 6478} -cleanup { 6479 chan close $f 6480 update 6481} -result {{delrecursive calling recursive} {delrecursive deleting recursive}} 6482test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { 6483 file delete $path(test1) 6484 set f [open $path(test1) w] 6485 chan close $f 6486 update 6487} -constraints {testchannelevent testservicemode notOSX} -body { 6488 proc notcalled {f} { 6489 variable z 6490 lappend z "notcalled was called!! $f" 6491 } 6492 proc del {f} { 6493 variable u 6494 variable z 6495 if {$u eq "recursive"} { 6496 testchannelevent $f delete 1 6497 testchannelevent $f delete 0 6498 lappend z "del deleted notcalled" 6499 lappend z "del deleted myself" 6500 } else { 6501 set u recursive 6502 lappend z "del calling recursive" 6503 set timer [after 50 lappend z timeout] 6504 set mode [testservicemode 1] 6505 vwait z 6506 after cancel $timer 6507 testservicemode $mode 6508 lappend z "del after update" 6509 } 6510 } 6511 set z "" 6512 set u toplevel 6513 set timer [after 50 lappend z timeout] 6514 testservicemode 0 6515 set f [open $path(test1) r] 6516 testchannelevent $f add readable [namespace code [list notcalled $f]] 6517 testchannelevent $f add readable [namespace code [list del $f]] 6518 testservicemode 1 6519 vwait z 6520 after cancel $timer 6521 set z 6522} -cleanup { 6523 chan close $f 6524 update 6525} -result [list {del calling recursive} {del deleted notcalled} \ 6526 {del deleted myself} {del after update}] 6527test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { 6528 file delete $path(test1) 6529 set f [open $path(test1) w] 6530 chan close $f 6531} -constraints {testchannelevent testservicemode} -body { 6532 proc first {f} { 6533 variable u 6534 variable z 6535 if {$u eq "toplevel"} { 6536 lappend z "first called" 6537 set mode [testservicemode 1] 6538 set timer [after 50 lappend z timeout] 6539 set u first 6540 vwait z 6541 after cancel $timer 6542 testservicemode $mode 6543 lappend z "first after update" 6544 } else { 6545 lappend z "first called not toplevel" 6546 } 6547 } 6548 proc second {f} { 6549 variable u 6550 variable z 6551 if {$u eq "first"} { 6552 lappend z "second called, first time" 6553 set u second 6554 testchannelevent $f delete 0 6555 } elseif {$u eq "second"} { 6556 lappend z "second called, second time" 6557 testchannelevent $f delete 0 6558 } else { 6559 lappend z "second called, cannot happen!" 6560 testchannelevent $f removeall 6561 } 6562 } 6563 set z "" 6564 set u toplevel 6565 set timer [after 50 lappend z timeout] 6566 testservicemode 0 6567 set f [open $path(test1) r] 6568 testchannelevent $f add readable [namespace code [list second $f]] 6569 testchannelevent $f add readable [namespace code [list first $f]] 6570 testservicemode 1 6571 vwait z 6572 after cancel $timer 6573 set z 6574} -cleanup { 6575 chan close $f 6576} -result [list {first called} {first called not toplevel} \ 6577 {second called, first time} {second called, second time} \ 6578 {first after update}] 6579 6580test chan-io-51.1 {Test old socket deletion on Macintosh} -setup { 6581 set x 0 6582 set result "" 6583 variable wait "" 6584} -constraints {socket} -body { 6585 proc accept {s a p} { 6586 variable x 6587 chan configure $s -blocking off 6588 chan puts $s "sock[incr x]" 6589 chan close $s 6590 variable wait done 6591 } 6592 set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 6593 set port [lindex [chan configure $ss -sockname] 2] 6594 set cs [socket 127.0.0.1 $port] 6595 vwait [namespace which -variable wait] 6596 lappend result [chan gets $cs] 6597 chan close $cs 6598 set cs [socket 127.0.0.1 $port] 6599 vwait [namespace which -variable wait] 6600 lappend result [chan gets $cs] 6601 chan close $cs 6602 set cs [socket 127.0.0.1 $port] 6603 vwait [namespace which -variable wait] 6604 lappend result [chan gets $cs] 6605 chan close $cs 6606 set cs [socket 127.0.0.1 $port] 6607 vwait [namespace which -variable wait] 6608 lappend result [chan gets $cs] 6609} -cleanup { 6610 chan close $cs 6611 chan close $ss 6612} -result {sock1 sock2 sock3 sock4} 6613 6614test chan-io-52.1 {TclCopyChannel} -constraints {fcopy} -setup { 6615 file delete $path(test1) 6616} -body { 6617 set f1 [open $thisScript] 6618 set f2 [open $path(test1) w] 6619 chan copy $f1 $f2 -command " # " 6620 chan copy $f1 $f2 6621} -returnCodes error -cleanup { 6622 chan close $f1 6623 chan close $f2 6624} -match glob -result {channel "*" is busy} 6625test chan-io-52.2 {TclCopyChannel} -constraints {fcopy} -setup { 6626 file delete $path(test1) 6627} -body { 6628 set f1 [open $thisScript] 6629 set f2 [open $path(test1) w] 6630 set f3 [open $thisScript] 6631 chan copy $f1 $f2 -command " # " 6632 chan copy $f3 $f2 6633} -returnCodes error -cleanup { 6634 chan close $f1 6635 chan close $f2 6636 chan close $f3 6637} -match glob -result {channel "*" is busy} 6638test chan-io-52.3 {TclCopyChannel} -constraints {fcopy} -setup { 6639 file delete $path(test1) 6640} -body { 6641 set f1 [open $thisScript] 6642 set f2 [open $path(test1) w] 6643 chan configure $f1 -translation lf -blocking 0 6644 chan configure $f2 -translation cr -blocking 0 6645 set s0 [chan copy $f1 $f2] 6646 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6647 chan close $f1 6648 chan close $f2 6649 set s1 [file size $thisScript] 6650 set s2 [file size $path(test1)] 6651 if {($s1 == $s2) && ($s0 == $s1)} { 6652 lappend result ok 6653 } 6654 return $result 6655} -result {0 0 ok} 6656test chan-io-52.4 {TclCopyChannel} -constraints {fcopy} -setup { 6657 file delete $path(test1) 6658} -body { 6659 set f1 [open $thisScript] 6660 set f2 [open $path(test1) w] 6661 chan configure $f1 -translation lf -blocking 0 6662 chan configure $f2 -translation cr -blocking 0 6663 chan copy $f1 $f2 -size 40 6664 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6665 chan close $f1 6666 chan close $f2 6667 lappend result [file size $path(test1)] 6668} -result {0 0 40} 6669test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup { 6670 file delete $path(test1) 6671} -body { 6672 set f1 [open $thisScript] 6673 set f2 [open $path(test1) w] 6674 chan configure $f1 -translation lf -blocking 0 6675 chan configure $f2 -translation lf -blocking 0 6676 chan copy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified. 6677 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6678 chan close $f1 6679 chan close $f2 6680 if {[file size $thisScript] == [file size $path(test1)]} { 6681 lappend result ok 6682 } 6683 return $result 6684} -result {0 0 ok} 6685test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup { 6686 file delete $path(test1) 6687} -constraints {fcopy} -body { 6688 set f1 [open $thisScript] 6689 set f2 [open $path(test1) w] 6690 chan configure $f1 -translation lf -blocking 0 6691 chan configure $f2 -translation lf -blocking 0 6692 chan copy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all 6693 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6694 chan close $f1 6695 chan close $f2 6696 if {[file size $thisScript] == [file size $path(test1)]} { 6697 lappend result ok 6698 } 6699 return $result 6700} -result {0 0 ok} 6701test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup { 6702 file delete $path(test1) 6703} -constraints {fcopy} -body { 6704 set f1 [open $thisScript] 6705 set f2 [open $path(test1) w] 6706 chan configure $f1 -translation lf -blocking 0 6707 chan configure $f2 -translation lf -blocking 0 6708 chan copy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all 6709 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6710 chan close $f1 6711 chan close $f2 6712 if {[file size $thisScript] == [file size $path(test1)]} { 6713 lappend result ok 6714 } 6715 return $result 6716} -result {0 0 ok} 6717test chan-io-52.6 {TclCopyChannel} -setup { 6718 file delete $path(test1) 6719} -constraints {fcopy} -body { 6720 set f1 [open $thisScript] 6721 set f2 [open $path(test1) w] 6722 chan configure $f1 -translation lf -blocking 0 6723 chan configure $f2 -translation lf -blocking 0 6724 set s0 [chan copy $f1 $f2 -size [expr {[file size $thisScript] + 5}]] 6725 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6726 chan close $f1 6727 chan close $f2 6728 set s1 [file size $thisScript] 6729 set s2 [file size $path(test1)] 6730 if {($s1 == $s2) && ($s0 == $s1)} { 6731 lappend result ok 6732 } 6733 return $result 6734} -result {0 0 ok} 6735test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup { 6736 file delete $path(test1) 6737} -body { 6738 set f1 [open $thisScript] 6739 set f2 [open $path(test1) w] 6740 chan configure $f1 -translation lf -blocking 0 6741 chan configure $f2 -translation lf -blocking 0 6742 chan copy $f1 $f2 6743 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6744 if {[file size $thisScript] == [file size $path(test1)]} { 6745 lappend result ok 6746 } 6747 return $result 6748} -cleanup { 6749 chan close $f1 6750 chan close $f2 6751} -result {0 0 ok} 6752test chan-io-52.8 {TclCopyChannel} -setup { 6753 file delete $path(test1) 6754 file delete $path(pipe) 6755} -constraints {stdio fcopy} -body { 6756 set f1 [open $path(pipe) w] 6757 chan configure $f1 -translation lf 6758 chan puts $f1 " 6759 chan puts ready 6760 chan gets stdin 6761 set f1 \[open [list $thisScript] r\] 6762 chan configure \$f1 -translation lf 6763 chan puts \[chan read \$f1 100\] 6764 chan close \$f1 6765 " 6766 chan close $f1 6767 set f1 [openpipe r+ $path(pipe)] 6768 chan configure $f1 -translation lf 6769 chan gets $f1 6770 chan puts $f1 ready 6771 chan flush $f1 6772 set f2 [open $path(test1) w] 6773 chan configure $f2 -translation lf 6774 set s0 [chan copy $f1 $f2 -size 40] 6775 catch {chan close $f1} 6776 chan close $f2 6777 list $s0 [file size $path(test1)] 6778} -result {40 40} 6779# Empty files, to register them with the test facility 6780set path(kyrillic.txt) [makeFile {} kyrillic.txt] 6781set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt] 6782set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] 6783# Create kyrillic file, use lf translation to avoid os eol issues 6784set out [open $path(kyrillic.txt) w] 6785chan configure $out -encoding koi8-r -translation lf 6786chan puts $out "АА" 6787chan close $out 6788test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} { 6789 # Copy kyrillic to UTF-8, using chan copy. 6790 set in [open $path(kyrillic.txt) r] 6791 set out [open $path(utf8-fcopy.txt) w] 6792 chan configure $in -encoding koi8-r -translation lf 6793 chan configure $out -encoding utf-8 -translation lf 6794 chan copy $in $out 6795 chan close $in 6796 chan close $out 6797 # Do the same again, but differently (read/chan puts). 6798 set in [open $path(kyrillic.txt) r] 6799 set out [open $path(utf8-rp.txt) w] 6800 chan configure $in -encoding koi8-r -translation lf 6801 chan configure $out -encoding utf-8 -translation lf 6802 chan puts -nonewline $out [chan read $in] 6803 chan close $in 6804 chan close $out 6805 list [file size $path(kyrillic.txt)] \ 6806 [file size $path(utf8-fcopy.txt)] \ 6807 [file size $path(utf8-rp.txt)] 6808} {3 5 5} 6809test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { 6810 # encoding to binary (=> implies that the internal utf-8 is written) 6811 set in [open $path(kyrillic.txt) r] 6812 set out [open $path(utf8-fcopy.txt) w] 6813 chan configure $in -encoding koi8-r -translation lf 6814 # -translation binary is also -encoding binary 6815 chan configure $out -translation binary 6816 chan copy $in $out 6817 chan close $in 6818 chan close $out 6819 file size $path(utf8-fcopy.txt) 6820} 5 6821test chan-io-52.11 {TclCopyChannel & encodings} -setup { 6822 set f [open $path(utf8-fcopy.txt) w] 6823 fconfigure $f -encoding utf-8 -translation lf 6824 puts $f "АА" 6825 close $f 6826} -constraints {fcopy} -body { 6827 # binary to encoding => the input has to be in utf-8 to make sense to the 6828 # encoder 6829 set in [open $path(utf8-fcopy.txt) r] 6830 set out [open $path(kyrillic.txt) w] 6831 # -translation binary is also -encoding binary 6832 chan configure $in -translation binary 6833 chan configure $out -encoding koi8-r -translation lf 6834 chan copy $in $out 6835 chan close $in 6836 chan close $out 6837 file size $path(kyrillic.txt) 6838} -result 3 6839 6840test chan-io-53.1 {CopyData} -setup { 6841 file delete $path(test1) 6842} -constraints {fcopy} -body { 6843 set f1 [open $thisScript] 6844 set f2 [open $path(test1) w] 6845 chan configure $f1 -translation lf -blocking 0 6846 chan configure $f2 -translation cr -blocking 0 6847 chan copy $f1 $f2 -size 0 6848 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6849 chan close $f1 6850 chan close $f2 6851 lappend result [file size $path(test1)] 6852} -result {0 0 0} 6853test chan-io-53.2 {CopyData} -setup { 6854 file delete $path(test1) 6855} -constraints {fcopy} -body { 6856 set f1 [open $thisScript] 6857 set f2 [open $path(test1) w] 6858 chan configure $f1 -translation lf -blocking 0 6859 chan configure $f2 -translation cr -blocking 0 6860 chan copy $f1 $f2 -command [namespace code {set s0}] 6861 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] 6862 variable s0 6863 vwait [namespace which -variable s0] 6864 chan close $f1 6865 chan close $f2 6866 set s1 [file size $thisScript] 6867 set s2 [file size $path(test1)] 6868 if {($s1 == $s2) && ($s0 == $s1)} { 6869 lappend result ok 6870 } 6871 return $result 6872} -result {0 0 ok} 6873test chan-io-53.3 {CopyData: background read underflow} -setup { 6874 file delete $path(test1) 6875 file delete $path(pipe) 6876} -constraints {stdio unix fcopy} -body { 6877 set f1 [open $path(pipe) w] 6878 chan puts -nonewline $f1 { 6879 chan puts ready 6880 chan flush stdout ;# Don't assume line buffered! 6881 chan copy stdin stdout -command { set x } 6882 vwait x 6883 set f [} 6884 chan puts $f1 [list open $path(test1) w]] 6885 chan puts $f1 { 6886 chan configure $f -translation lf 6887 chan puts $f "done" 6888 chan close $f 6889 } 6890 chan close $f1 6891 set f1 [openpipe r+ $path(pipe)] 6892 set result [chan gets $f1] 6893 chan puts $f1 line1 6894 chan flush $f1 6895 lappend result [chan gets $f1] 6896 chan puts $f1 line2 6897 chan flush $f1 6898 lappend result [chan gets $f1] 6899 chan close $f1 6900 after 500 6901 set f [open $path(test1)] 6902 lappend result [chan read $f] 6903} -cleanup { 6904 chan close $f 6905} -result "ready line1 line2 {done\n}" 6906test chan-io-53.4 {CopyData: background write overflow} -setup { 6907 set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n 6908 variable x 6909 for {set x 0} {$x < 12} {incr x} { 6910 append big $big 6911 } 6912 file delete $path(test1) 6913 file delete $path(pipe) 6914} -constraints {stdio unix fileevent fcopy} -body { 6915 set f1 [open $path(pipe) w] 6916 chan puts $f1 { 6917 chan puts ready 6918 chan copy stdin stdout -command { set x } 6919 vwait x 6920 set f [open $path(test1) w] 6921 chan configure $f -translation lf 6922 chan puts $f "done" 6923 chan close $f 6924 } 6925 chan close $f1 6926 set f1 [openpipe r+ $path(pipe)] 6927 set result [chan gets $f1] 6928 chan configure $f1 -blocking 0 6929 chan puts $f1 $big 6930 chan flush $f1 6931 after 500 6932 set result "" 6933 chan event $f1 read [namespace code { 6934 append result [chan read $f1 1024] 6935 if {[string length $result] >= [string length $big]} { 6936 set x done 6937 } 6938 }] 6939 vwait [namespace which -variable x] 6940 return $x 6941} -cleanup { 6942 set big {} 6943 chan close $f1 6944} -result done 6945set result {} 6946proc FcopyTestAccept {sock args} { 6947 after 1000 "chan close $sock" 6948} 6949proc FcopyTestDone {bytes {error {}}} { 6950 variable fcopyTestDone 6951 if {[string length $error]} { 6952 set fcopyTestDone 1 6953 } else { 6954 set fcopyTestDone 0 6955 } 6956} 6957test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} { 6958 variable fcopyTestDone 6959 set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0] 6960 set in [open $thisScript] ;# 126 K 6961 set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]] 6962 catch {unset fcopyTestDone} 6963 chan close $listen ;# This means the socket open never really succeeds 6964 chan copy $in $out -command [namespace code FcopyTestDone] 6965 variable fcopyTestDone 6966 if {![info exists fcopyTestDone]} { 6967 vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. 6968 } 6969 chan close $in 6970 chan close $out 6971 set fcopyTestDone ;# 1 for error condition 6972} 1 6973test chan-io-53.6 {CopyData: error during chan copy} -setup { 6974 variable fcopyTestDone 6975 file delete $path(pipe) 6976 file delete $path(test1) 6977 catch {unset fcopyTestDone} 6978} -constraints {stdio fcopy} -body { 6979 set f1 [open $path(pipe) w] 6980 chan puts $f1 "exit 1" 6981 chan close $f1 6982 set in [openpipe r+ $path(pipe)] 6983 set out [open $path(test1) w] 6984 chan copy $in $out -command [namespace code FcopyTestDone] 6985 variable fcopyTestDone 6986 if {![info exists fcopyTestDone]} { 6987 vwait [namespace which -variable fcopyTestDone] 6988 } 6989 return $fcopyTestDone ;# 0 for plain end of file 6990} -cleanup { 6991 catch {chan close $in} 6992 chan close $out 6993} -result 0 6994proc doFcopy {in out {bytes 0} {error {}}} { 6995 variable fcopyTestDone 6996 variable fcopyTestCount 6997 incr fcopyTestCount $bytes 6998 if {[string length $error]} { 6999 set fcopyTestDone 1 7000 } elseif {[chan eof $in]} { 7001 set fcopyTestDone 0 7002 } else { 7003 # Delay next chan copy to wait for size>0 input bytes 7004 after 100 [list chan copy $in $out -size 1000 \ 7005 -command [namespace code [list doFcopy $in $out]]] 7006 } 7007} 7008test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { 7009 variable fcopyTestDone 7010 file delete $path(pipe) 7011 catch {unset fcopyTestDone} 7012} -constraints {stdio fcopy} -body { 7013 set fcopyTestCount 0 7014 set f1 [open $path(pipe) w] 7015 chan puts $f1 { 7016 # Write 10 bytes / 10 msec 7017 proc Write {count} { 7018 chan puts -nonewline "1234567890" 7019 if {[incr count -1]} { 7020 after 10 [list Write $count] 7021 } else { 7022 set ::ready 1 7023 } 7024 } 7025 chan configure stdout -buffering none 7026 Write 345 ;# 3450 bytes ~3.45 sec 7027 vwait ready 7028 exit 0 7029 } 7030 chan close $f1 7031 set in [openpipe r+ $path(pipe) &] 7032 set out [open $path(test1) w] 7033 doFcopy $in $out 7034 variable fcopyTestDone 7035 if {![info exists fcopyTestDone]} { 7036 vwait [namespace which -variable fcopyTestDone] 7037 } 7038 # -1=error 0=script error N=number of bytes 7039 expr {($fcopyTestDone == 0) ? $fcopyTestCount : -1} 7040} -cleanup { 7041 catch {chan close $in} 7042 chan close $out 7043} -result {3450} 7044test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { 7045 # copy progress callback. errors out intentionally 7046 proc cmd args { 7047 lappend ::RES "CMD $args" 7048 error !STOP 7049 } 7050 # capture callback error here 7051 proc ::bgerror args { 7052 lappend ::RES "bgerror/OK $args" 7053 set ::forever has-been-reached 7054 return 7055 } 7056 # Files we use for our channels 7057 set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] 7058 set bar [makeFile {} bar] 7059 # Channels to copy between 7060 set f [open $foo r] ; fconfigure $f -translation binary 7061 set g [open $bar w] ; fconfigure $g -translation binary -buffering none 7062} -constraints {stdio fcopy} -body { 7063 # Record input size, so that result is always defined 7064 lappend ::RES [file size $bar] 7065 # Run the copy. Should not invoke -command now. 7066 chan copy $f $g -size 2 -command [namespace code cmd] 7067 # Check that -command was not called synchronously 7068 set sbs [file size $bar] 7069 lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs 7070 # Now let the async part happen. Should capture the error in cmd via 7071 # bgerror. If not break the event loop via timer. 7072 set token [after 1000 { 7073 lappend ::RES {bgerror/FAIL timeout} 7074 set ::forever has-been-reached 7075 }] 7076 vwait ::forever 7077 catch {after cancel $token} 7078 # Report 7079 set ::RES 7080} -cleanup { 7081 chan close $f 7082 chan close $g 7083 catch {unset ::RES} 7084 catch {unset ::forever} 7085 rename ::bgerror {} 7086 removeFile foo 7087 removeFile bar 7088} -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}} 7089test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} -setup { 7090 # copy progress callback. 7091 proc cmd args { 7092 lappend ::RES "CMD $args" 7093 set ::forever has-been-reached 7094 return 7095 } 7096 # Files we use for our channels 7097 set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] 7098 set bar [makeFile {} bar] 7099 # Channels to copy between 7100 set f [open $foo r] ; chan configure $f -translation binary 7101 set g [open $bar w] ; chan configure $g -translation binary -buffering none 7102} -constraints {stdio fcopy} -body { 7103 # Initialize and force eof on the input. 7104 chan seek $f 0 end ; chan read $f 1 7105 set ::RES [chan eof $f] 7106 # Run the copy. Should not invoke -command now. 7107 chan copy $f $g -size 2 -command [namespace code cmd] 7108 # Check that -command was not called synchronously 7109 lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] 7110 # Now let the async part happen. Should capture the eof in cmd 7111 # If not break the event loop via timer. 7112 set token [after 1000 { 7113 lappend ::RES {cmd/FAIL timeout} 7114 set ::forever has-been-reached 7115 }] 7116 vwait ::forever 7117 catch {after cancel $token} 7118 # Report 7119 return $::RES 7120} -cleanup { 7121 chan close $f 7122 chan close $g 7123 catch {unset ::RES} 7124 catch {unset ::forever} 7125 removeFile foo 7126 removeFile bar 7127} -result {1 sync/OK {CMD 0}} 7128test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { 7129 set out [makeFile {} out] 7130 set err [makeFile {} err] 7131 set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] 7132 chan configure $pipe -translation binary -buffering line 7133 chan puts $pipe { 7134 chan configure stdout -translation binary -buffering line 7135 chan puts stderr Waiting... 7136 after 1000 7137 foreach x {a b c} { 7138 chan puts stderr Looping... 7139 chan puts $x 7140 after 500 7141 } 7142 proc bye args { 7143 if {[chan gets stdin line]<0} { 7144 chan puts stderr "CHILD: EOF detected, exiting" 7145 exit 7146 } else { 7147 chan puts stderr "CHILD: ignoring line: $line" 7148 } 7149 } 7150 chan puts stderr Now-sleeping-forever 7151 chan event stdin readable bye 7152 vwait forever 7153 } 7154 proc ::done args { 7155 set ::forever OK 7156 return 7157 } 7158 set ::forever {} 7159 set out [open $out w] 7160} -constraints {stdio fcopy} -body { 7161 chan copy $pipe $out -size 6 -command ::done 7162 set token [after 5000 { 7163 set ::forever {fcopy hangs} 7164 }] 7165 vwait ::forever 7166 catch {after cancel $token} 7167 set ::forever 7168} -cleanup { 7169 chan close $pipe 7170 rename ::done {} 7171 if {[testConstraint win]} { 7172 after 1000; # Allow Windows time to figure out that the 7173 # process is gone 7174 } 7175 catch {close $out} 7176 catch {removeFile out} 7177 catch {removeFile err} 7178 catch {unset ::forever} 7179} -result OK 7180test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { 7181 set err [makeFile {} err] 7182 set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] 7183 chan configure $pipe -translation binary -buffering line 7184 chan puts $pipe { 7185 chan configure stderr -buffering line 7186 # Kill server when pipe closed by invoker. 7187 proc bye args { 7188 if {![chan eof stdin]} { chan gets stdin ; return } 7189 chan puts stderr BYE 7190 exit 7191 } 7192 # Server code. Bi-directional copy between 2 sockets. 7193 proc geof {sok} { 7194 chan puts stderr DONE/$sok 7195 chan close $sok 7196 } 7197 proc new {sok args} { 7198 chan puts stderr NEW/$sok 7199 global l srv 7200 chan configure $sok -translation binary -buffering none 7201 lappend l $sok 7202 if {[llength $l] == 2} { 7203 chan close $srv 7204 foreach {a b} $l break 7205 chan copy $a $b -command [list geof $a] 7206 chan copy $b $a -command [list geof $b] 7207 chan puts stderr 2COPY 7208 } 7209 chan puts stderr ... 7210 } 7211 chan puts stderr SRV 7212 set l {} 7213 set srv [socket -server new 9999] 7214 chan puts stderr WAITING 7215 chan event stdin readable bye 7216 chan puts OK 7217 vwait forever 7218 } 7219 # wait for OK from server. 7220 chan gets $pipe 7221 # Now the two clients. 7222 proc done {sock} { 7223 if {[chan eof $sock]} { chan close $sock ; return } 7224 lappend ::forever [chan gets $sock] 7225 return 7226 } 7227 set a [socket 127.0.0.1 9999] 7228 set b [socket 127.0.0.1 9999] 7229 chan configure $a -translation binary -buffering none 7230 chan configure $b -translation binary -buffering none 7231 chan event $a readable [namespace code "done $a"] 7232 chan event $b readable [namespace code "done $b"] 7233} -constraints {stdio fcopy} -body { 7234 # Now pass data through the server in both directions. 7235 set ::forever {} 7236 chan puts $a AB 7237 vwait ::forever 7238 chan puts $b BA 7239 vwait ::forever 7240 set ::forever 7241} -cleanup { 7242 catch {chan close $a} 7243 catch {chan close $b} 7244 chan close $pipe 7245 if {[testConstraint win]} { 7246 after 1000 ;# Give Windows time to kill the process 7247 } 7248 removeFile err 7249 catch {unset ::forever} 7250} -result {AB BA} 7251 7252test chan-io-54.1 {Recursive channel events} {socket fileevent} { 7253 # This test checks to see if file events are delivered during recursive 7254 # event loops when there is buffered data on the channel. 7255 proc accept {s a p} { 7256 variable as 7257 chan configure $s -translation lf 7258 chan puts $s "line 1\nline2\nline3" 7259 chan flush $s 7260 set as $s 7261 } 7262 proc readit {s next} { 7263 variable x 7264 variable result 7265 lappend result $next 7266 if {$next == 1} { 7267 chan event $s readable [namespace code [list readit $s 2]] 7268 vwait [namespace which -variable x] 7269 } 7270 incr x 7271 } 7272 set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 7273 # We need to delay on some systems until the creation of the server socket 7274 # completes. 7275 set done 0 7276 for {set i 0} {$i < 10} {incr i} { 7277 if {![catch { 7278 set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] 7279 }]} { 7280 set done 1 7281 break 7282 } 7283 after 100 7284 } 7285 if {$done == 0} { 7286 chan close $ss 7287 error "failed to connect to server" 7288 } 7289 variable result {} 7290 variable x 0 7291 variable as 7292 vwait [namespace which -variable as] 7293 chan configure $cs -translation lf 7294 lappend result [chan gets $cs] 7295 chan configure $cs -blocking off 7296 chan event $cs readable [namespace code [list readit $cs 1]] 7297 set a [after 2000 [namespace code { set x failure }]] 7298 vwait [namespace which -variable x] 7299 after cancel $a 7300 chan close $as 7301 chan close $ss 7302 chan close $cs 7303 list $result $x 7304} {{{line 1} 1 2} 2} 7305test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { 7306 set accept {} 7307 set after {} 7308 variable done 0 7309} -constraints {socket fileevent} -body { 7310 variable s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 7311 proc accept {s a p} { 7312 variable counter 0 7313 variable accept $s 7314 chan configure $s -blocking off -buffering line -translation lf 7315 chan event $s readable [namespace code "doit $s"] 7316 } 7317 proc doit {s} { 7318 variable counter 7319 variable after 7320 incr counter 7321 if {[chan gets $s] eq ""} { 7322 chan event $s readable [namespace code "doit1 $s"] 7323 set after [after 1000 [namespace code { 7324 chan puts $writer hello 7325 chan flush $writer 7326 set done 1 7327 }]] 7328 } 7329 } 7330 proc doit1 {s} { 7331 variable counter 7332 variable accept 7333 incr counter 7334 chan gets $s 7335 chan close $s 7336 set accept {} 7337 } 7338 proc producer {} { 7339 variable s 7340 variable writer 7341 set writer [socket 127.0.0.1 [lindex [chan configure $s -sockname] 2]] 7342 chan configure $writer -buffering line 7343 chan puts -nonewline $writer hello 7344 chan flush $writer 7345 } 7346 producer 7347 vwait [namespace which -variable done] 7348 chan close $writer 7349 chan close $s 7350 after cancel $after 7351 set counter 7352} -cleanup { 7353 if {$accept ne {}} {chan close $accept} 7354} -result 1 7355 7356set path(fooBar) [makeFile {} fooBar] 7357 7358test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints { 7359 fileevent 7360} -setup { 7361 variable x 7362 proc eventScript {fd} { 7363 variable x 7364 chan close $fd 7365 error "planned error" 7366 set x whoops 7367 } 7368 proc myHandler args { 7369 variable x got_error 7370 } 7371 set handler [interp bgerror {}] 7372 interp bgerror {} [namespace which myHandler] 7373} -body { 7374 set f [open $path(fooBar) w] 7375 chan event $f writable [namespace code [list eventScript $f]] 7376 variable x not_done 7377 vwait [namespace which -variable x] 7378 set x 7379} -cleanup { 7380 interp bgerror {} $handler 7381} -result {got_error} 7382 7383test chan-io-56.1 {ChannelTimerProc} {testchannelevent} { 7384 set f [open $path(fooBar) w] 7385 chan puts $f "this is a test" 7386 chan close $f 7387 set f [open $path(fooBar) r] 7388 testchannelevent $f add readable [namespace code { 7389 chan read $f 1 7390 incr x 7391 }] 7392 variable x 0 7393 vwait [namespace which -variable x] 7394 vwait [namespace which -variable x] 7395 set result $x 7396 testchannelevent $f set 0 none 7397 after idle [namespace code {set y done}] 7398 variable y 7399 vwait [namespace which -variable y] 7400 chan close $f 7401 lappend result $y 7402} {2 done} 7403 7404test chan-io-57.1 {buffered data and file events, gets} -setup { 7405 variable s2 7406} -constraints {fileevent} -body { 7407 proc accept {sock args} { 7408 variable s2 7409 set s2 $sock 7410 } 7411 set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 7412 set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] 7413 vwait [namespace which -variable s2] 7414 update 7415 chan event $s2 readable [namespace code {lappend result readable}] 7416 chan puts $s "12\n34567890" 7417 chan flush $s 7418 variable result [chan gets $s2] 7419 after 1000 [namespace code {lappend result timer}] 7420 vwait [namespace which -variable result] 7421 lappend result [chan gets $s2] 7422 vwait [namespace which -variable result] 7423 set result 7424} -cleanup { 7425 chan close $s 7426 chan close $s2 7427 chan close $server 7428} -result {12 readable 34567890 timer} 7429test chan-io-57.2 {buffered data and file events, read} -setup { 7430 variable s2 7431} -constraints {fileevent} -body { 7432 proc accept {sock args} { 7433 variable s2 7434 set s2 $sock 7435 } 7436 set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] 7437 set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] 7438 vwait [namespace which -variable s2] 7439 update 7440 chan event $s2 readable [namespace code {lappend result readable}] 7441 chan puts -nonewline $s "1234567890" 7442 chan flush $s 7443 variable result [chan read $s2 1] 7444 after 1000 [namespace code {lappend result timer}] 7445 vwait [namespace which -variable result] 7446 lappend result [chan read $s2 9] 7447 vwait [namespace which -variable result] 7448 set result 7449} -cleanup { 7450 chan close $s 7451 chan close $s2 7452 chan close $server 7453} -result {1 readable 234567890 timer} 7454 7455test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { 7456 set out [open $path(script) w] 7457 chan puts $out { 7458 chan puts "normal message from pipe" 7459 chan puts stderr "error message from pipe" 7460 exit 1 7461 } 7462 proc readit {pipe} { 7463 variable x 7464 variable result 7465 if {[chan eof $pipe]} { 7466 set x [catch {chan close $pipe} line] 7467 lappend result catch $line 7468 } else { 7469 chan gets $pipe line 7470 lappend result chan gets $line 7471 } 7472 } 7473 chan close $out 7474 set pipe [openpipe r $path(script)] 7475 chan event $pipe readable [namespace code [list readit $pipe]] 7476 variable x "" 7477 set result "" 7478 vwait [namespace which -variable x] 7479 list $x $result 7480} {1 {chan gets {normal message from pipe} chan gets {} catch {error message from pipe}}} 7481 7482test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} { 7483 # TIP #10 7484 # More complicated tests (like that the reference changes as a channel is 7485 # moved from thread to thread) can be done only in the extension which 7486 # fully implements the moving of channels between threads, i.e. 'Threads'. 7487 set f [open $path(longfile) r] 7488 set result [testchannel mthread $f] 7489 chan close $f 7490 string equal $result [testmainthread] 7491} {1} 7492 7493test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { 7494 # This test will hang in older revisions of the core. 7495 set out [open $path(script) w] 7496 chan puts $out "catch {load $::tcltestlib Tcltest}" 7497 chan puts $out { 7498 chan puts [testbytestring \xE2] 7499 exit 1 7500 } 7501 proc readit {pipe} { 7502 variable x 7503 variable result 7504 if {[chan eof $pipe]} { 7505 set x [catch {chan close $pipe} line] 7506 lappend result catch $line 7507 } else { 7508 chan gets $pipe line 7509 lappend result gets $line 7510 } 7511 } 7512 chan close $out 7513 set pipe [openpipe r $path(script)] 7514 chan event $pipe readable [namespace code [list readit $pipe]] 7515 variable x "" 7516 set result "" 7517 vwait [namespace which -variable x] 7518 # cut of the remainder of the error stack, especially the filename 7519 set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]] 7520 list $x $result 7521} {1 {gets {} catch {error writing "stdout": illegal byte sequence}}} 7522 7523test chan-io-61.1 {Reset eof state after changing the eof char} -setup { 7524 set datafile [makeFile {} eofchar] 7525 set f [open $datafile w] 7526 chan configure $f -translation binary 7527 chan puts -nonewline $f [string repeat "Ho hum\n" 11] 7528 chan puts $f = 7529 set line [string repeat "Ge gla " 4] 7530 chan puts -nonewline $f [string repeat [string trimright $line]\n 834] 7531 chan close $f 7532} -body { 7533 set f [open $datafile r] 7534 chan configure $f -eofchar = 7535 set res {} 7536 lappend res [chan read $f; chan tell $f] 7537 chan configure $f -eofchar {} 7538 lappend res [chan read $f 1] 7539 lappend res [chan read $f; chan tell $f] 7540 # Any seek zaps the internals into a good state. 7541 #chan seek $f 0 start 7542 #chan seek $f 0 current 7543 #lappend res [chan read $f; chan tell $f] 7544} -cleanup { 7545 chan close $f 7546 removeFile eofchar 7547} -result {77 = 23431} 7548 7549# Test the cutting and splicing of channels, this is incidentially the 7550# attach/detach facility of package Thread, but __without any safeguards__. It 7551# can also be used to emulate transfer of channels between threads, and is 7552# used for that here. 7553 7554test chan-io-70.0 {Cutting & Splicing channels} -setup { 7555 set f [makeFile {... dummy ...} cutsplice] 7556 set res {} 7557} -constraints {testchannel} -body { 7558 set c [open $f r] 7559 lappend res [catch {chan seek $c 0 start}] 7560 testchannel cut $c 7561 lappend res [catch {chan seek $c 0 start}] 7562 testchannel splice $c 7563 lappend res [catch {chan seek $c 0 start}] 7564} -cleanup { 7565 chan close $c 7566 removeFile cutsplice 7567} -result {0 1 0} 7568 7569test chan-io-70.1 {Transfer channel} -setup { 7570 set f [makeFile {... dummy ...} cutsplice] 7571 set res {} 7572} -constraints {testchannel thread} -body { 7573 set c [open $f r] 7574 lappend res [catch {chan seek $c 0 start}] 7575 testchannel cut $c 7576 lappend res [catch {chan seek $c 0 start}] 7577 set tid [thread::create -preserved] 7578 thread::send $tid [list set c $c] 7579 thread::send $tid {load {} Tcltest} 7580 lappend res [thread::send $tid { 7581 testchannel splice $c 7582 set res [catch {chan seek $c 0 start}] 7583 chan close $c 7584 set res 7585 }] 7586} -cleanup { 7587 thread::release $tid 7588 removeFile cutsplice 7589} -result {0 1 0} 7590 7591# ### ### ### ######### ######### ######### 7592 7593foreach {n msg expected} { 7594 0 {} {} 7595 1 {{message only}} {{message only}} 7596 2 {-options x} {-options x} 7597 3 {-options {x y} {the message}} {-options {x y} {the message}} 7598 7599 4 {-code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7600 5 {-code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7601 6 {-code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7602 7 {-code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7603 8 {-code error -level 0 -f ba snarf} {-code error -level 0 -f ba snarf} 7604 9 {-code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7605 10 {-code error -level 5 -f ba snarf} {-code error -level 0 -f ba snarf} 7606 11 {-code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7607 12 {-code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7608 13 {-code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7609 14 {-code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} 7610 15 {-code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 7611 16 {-code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} 7612 17 {-code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 7613 18 {-code error -level 0 -f ba} {-code error -level 0 -f ba} 7614 19 {-code ok -level 0 -f ba} {-code 1 -level 0 -f ba} 7615 20 {-code error -level 5 -f ba} {-code error -level 0 -f ba} 7616 21 {-code ok -level 5 -f ba} {-code 1 -level 0 -f ba} 7617 22 {-code boss -level 0 -f ba} {-code 1 -level 0 -f ba} 7618 23 {-code boss -level 5 -f ba} {-code 1 -level 0 -f ba} 7619 24 {-code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7620 25 {-code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7621 26 {-code error -level X -f ba snarf} {-code error -level 0 -f ba snarf} 7622 27 {-code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7623 28 {-code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7624 29 {-code 1 -level X -f ba} {-code 1 -level 0 -f ba} 7625 30 {-code 0 -level X -f ba} {-code 1 -level 0 -f ba} 7626 31 {-code error -level X -f ba} {-code error -level 0 -f ba} 7627 32 {-code ok -level X -f ba} {-code 1 -level 0 -f ba} 7628 33 {-code boss -level X -f ba} {-code 1 -level 0 -f ba} 7629 7630 34 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 7631 35 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7632 36 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 7633 37 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7634 38 {-code 1 -code error -level 0 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} 7635 39 {-code 1 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7636 40 {-code 1 -code error -level 5 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} 7637 41 {-code 1 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7638 42 {-code 1 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7639 43 {-code 1 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7640 44 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} 7641 45 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 7642 46 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} 7643 47 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 7644 48 {-code 1 -code error -level 0 -f ba} {-code 1 -code error -level 0 -f ba} 7645 49 {-code 1 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} 7646 50 {-code 1 -code error -level 5 -f ba} {-code 1 -code error -level 0 -f ba} 7647 51 {-code 1 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} 7648 52 {-code 1 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} 7649 53 {-code 1 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} 7650 54 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 7651 55 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7652 56 {-code 1 -code error -level X -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} 7653 57 {-code 1 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7654 58 {-code 1 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7655 59 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} 7656 60 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 7657 61 {-code 1 -code error -level X -f ba} {-code 1 -code error -level 0 -f ba} 7658 62 {-code 1 -code ok -level X -f ba} {-code 1 -level 0 -f ba} 7659 63 {-code 1 -code boss -level X -f ba} {-code 1 -level 0 -f ba} 7660 7661 64 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7662 65 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7663 66 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7664 67 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7665 68 {-code 0 -code error -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7666 69 {-code 0 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7667 70 {-code 0 -code error -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7668 71 {-code 0 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7669 72 {-code 0 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7670 73 {-code 0 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7671 74 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} 7672 75 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 7673 76 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} 7674 77 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 7675 78 {-code 0 -code error -level 0 -f ba} {-code 1 -level 0 -f ba} 7676 79 {-code 0 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} 7677 80 {-code 0 -code error -level 5 -f ba} {-code 1 -level 0 -f ba} 7678 81 {-code 0 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} 7679 82 {-code 0 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} 7680 83 {-code 0 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} 7681 84 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7682 85 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7683 86 {-code 0 -code error -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7684 87 {-code 0 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7685 88 {-code 0 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7686 89 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} 7687 90 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 7688 91 {-code 0 -code error -level X -f ba} {-code 1 -level 0 -f ba} 7689 92 {-code 0 -code ok -level X -f ba} {-code 1 -level 0 -f ba} 7690 93 {-code 0 -code boss -level X -f ba} {-code 1 -level 0 -f ba} 7691 7692 94 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 7693 95 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7694 96 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 7695 97 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7696 98 {-code error -code 1 -level 0 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} 7697 99 {-code ok -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7698 a0 {-code error -code 1 -level 5 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} 7699 a1 {-code ok -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7700 a2 {-code boss -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7701 a3 {-code boss -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7702 a4 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} 7703 a5 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} 7704 a6 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} 7705 a7 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} 7706 a8 {-code error -code 1 -level 0 -f ba} {-code error -code 1 -level 0 -f ba} 7707 a9 {-code ok -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} 7708 b0 {-code error -code 1 -level 5 -f ba} {-code error -code 1 -level 0 -f ba} 7709 b1 {-code ok -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} 7710 b2 {-code boss -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} 7711 b3 {-code boss -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} 7712 b4 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} 7713 b5 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7714 b6 {-code error -code 1 -level X -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} 7715 b7 {-code ok -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7716 b8 {-code boss -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7717 b9 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} 7718 c0 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} 7719 c1 {-code error -code 1 -level X -f ba} {-code error -code 1 -level 0 -f ba} 7720 c2 {-code ok -code 1 -level X -f ba} {-code 1 -level 0 -f ba} 7721 c3 {-code boss -code 1 -level X -f ba} {-code 1 -level 0 -f ba} 7722 7723 c4 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7724 c5 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7725 c6 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7726 c7 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7727 c8 {-code error -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7728 c9 {-code ok -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7729 d0 {-code error -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7730 d1 {-code ok -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7731 d2 {-code boss -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7732 d3 {-code boss -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} 7733 d4 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 7734 d5 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 7735 d6 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 7736 d7 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 7737 d8 {-code error -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 7738 d9 {-code ok -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 7739 e0 {-code error -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 7740 e1 {-code ok -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 7741 e2 {-code boss -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} 7742 e3 {-code boss -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} 7743 e4 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7744 e5 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7745 e6 {-code error -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7746 e7 {-code ok -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7747 e8 {-code boss -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} 7748 e9 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 7749 f0 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 7750 f1 {-code error -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 7751 f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 7752 f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba} 7753} { 7754 test chan-io-71.$n {Tcl_SetChannelError} -setup { 7755 set f [makeFile {... dummy ...} cutsplice] 7756 } -constraints {testchannel} -body { 7757 set c [open $f r] 7758 testchannel setchannelerror $c [lrange $msg 0 end] 7759 } -cleanup { 7760 chan close $c 7761 removeFile cutsplice 7762 } -result [lrange $expected 0 end] 7763 test chan-io-72.$n {Tcl_SetChannelErrorInterp} -setup { 7764 set f [makeFile {... dummy ...} cutsplice] 7765 } -constraints {testchannel} -body { 7766 set c [open $f r] 7767 testchannel setchannelerrorinterp $c [lrange $msg 0 end] 7768 } -cleanup { 7769 chan close $c 7770 removeFile cutsplice 7771 } -result [lrange $expected 0 end] 7772} 7773 7774test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} -body { 7775 # Test for Bug 1847044 - don't spoil type unless we have a valid channel 7776 chan close [lreplace [list a] 0 end] 7777} -returnCodes error -match glob -result * 7778 7779# ### ### ### ######### ######### ######### 7780 7781# cleanup 7782foreach file [list fooBar longfile script output test1 pipe my_script \ 7783 test2 test3 cat kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { 7784 removeFile $file 7785} 7786cleanupTests 7787} 7788namespace delete ::tcl::test::io 7789