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