diff options
Diffstat (limited to 'tests/io.test')
| -rw-r--r-- | tests/io.test | 204 |
1 files changed, 168 insertions, 36 deletions
diff --git a/tests/io.test b/tests/io.test index 94d8764..32c4b99 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6,9 +6,9 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -31,8 +31,8 @@ namespace eval ::tcl::test::io { catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] } package require tcltests @@ -108,14 +108,14 @@ set path(test1) [makeFile {} test1] test io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "a\u4E4D\x00" + puts -nonewline $f "a乍\x00" close $f contents $path(test1) } "a\x4D\x00" test io-1.7 {Tcl_WriteChars: WriteChars} { set f [open $path(test1) w] fconfigure $f -encoding shiftjis - puts -nonewline $f "a\u4e4d\x00" + puts -nonewline $f "a乍\x00" close $f contents $path(test1) } "a\x93\xE1\x00" @@ -299,14 +299,14 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # in src to the beginning of that UTF-8 character and try again. # # Translate the first 16 bytes, produce 14 bytes of output, 2 left over - # (first two bytes of \uFF21 in UTF-8). Given those two bytes try + # (first two bytes of Ａ in UTF-8). Given those two bytes try # translating them again, find that no bytes are read produced, and break # to outer loop where those two bytes will have the remaining 4 bytes - # (the last byte of \uFF21 plus the all of \uFF22) appended. + # (the last byte of Ａ plus the all of Ｂ) appended. set f [open $path(test1) w] fconfigure $f -encoding shiftjis -buffersize 16 - puts -nonewline $f "12345678901234\uFF21\uFF22" + puts -nonewline $f "12345678901234ＡＢ" set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] @@ -484,7 +484,7 @@ test io-6.5 {Tcl_GetsObj: encoding != NULL} { set x [list [gets $f line] $line] close $f set x -} [list 2 "\u4E00\u4E01"] +} [list 2 "一丁"] set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a @@ -524,7 +524,7 @@ test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { } {6 abcdef -1 {}} test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { set f [open $path(test1) w] - puts $f "abcdefghijk\nwom\u001Abat" + puts $f "abcdefghijk\nwom\x1Abat" close $f set f [open $path(test1)] fconfigure $f -eofchar \x1A @@ -938,7 +938,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio test set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none - fconfigure $f -encoding unicode + fconfigure $f -encoding utf-16 puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" fconfigure $f -buffersize 16 gets $f @@ -1067,14 +1067,14 @@ test io-6.55 {Tcl_GetsObj: overconverted} { set f [open $path(test1) w] fconfigure $f -encoding iso2022-jp - puts $f "there\u4E00ok\n\u4E01more bytes\nhere" + puts $f "there一ok\n丁more bytes\nhere" close $f set f [open $path(test1)] fconfigure $f -encoding iso2022-jp set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x -} [list 8 "there\u4E00ok" 11 "\u4E01more bytes" 4 "here"] +} [list 8 "there一ok" 11 "丁more bytes" 4 "here"] test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} { update set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1101,14 +1101,14 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { set f [open $path(test1) w] fconfigure $f -encoding shiftjis - puts $f "1234567890123\uFF10\uFF11\uFF12\uFF13\uFF14\nend" + puts $f "1234567890123０１２３４\nend" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis -buffersize 16 set x [gets $f] close $f set x -} "1234567890123\uFF10\uFF11\uFF12\uFF13\uFF14" +} "1234567890123０１２３４" test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) @@ -1134,7 +1134,7 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { lappend x [gets $f line] $line close $f set x -} [list 15 "1234567890123\uFF10\uFF11" 18 0 1 -1 ""] +} [list 15 "1234567890123０１" 18 0 1 -1 ""] test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -encoding binary -buffering none @@ -1153,7 +1153,7 @@ test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent vwait [namespace which -variable x] close $f set x -} [list -1 "" 1 17 "1234567890123\uFF10\uFF11\uFF12\uFF13" 0] +} [list -1 "" 1 17 "1234567890123０１２３" 0] test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} { # (bufPtr->nextPtr == NULL) @@ -1182,7 +1182,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha variable x lappend x [gets $f line] $line [testchannel inputbuffered $f] } - fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] fconfigure $f -translation auto -encoding ascii -blocking 1 # here @@ -1436,7 +1436,7 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} { vwait [namespace which -variable x] close $f set x -} [list "123456789012345" 1 "\u672C" 0] +} [list "123456789012345" 1 "本" 0] test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { set path(test1) [makeFile { fconfigure stdout -encoding binary -buffering none @@ -1469,7 +1469,7 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { vwait [namespace which -variable x] lappend x [catch {close $f} msg] $msg set x -} "{} timeout {} timeout \u7266 {} eof 0 {}" +} "{} timeout {} timeout 牦 {} eof 0 {}" test io-12.6 {ReadChars: too many chars read} { proc driver {cmd args} { variable buffer @@ -1479,7 +1479,7 @@ test io-12.6 {ReadChars: too many chars read} { initialize { set index($chan) 0 set buffer($chan) [encoding convertto utf-8 \ - [string repeat \uBEEF 20][string repeat . 20]] + [string repeat 뻯 20][string repeat . 20]] return {initialize finalize watch read} } finalize { @@ -1512,7 +1512,7 @@ test io-12.7 {ReadChars: too many chars read [bc5b790099]} { initialize { set index($chan) 0 set buffer($chan) [encoding convertto utf-8 \ - [string repeat \uBEEF 10]....\uBEEF] + [string repeat 뻯 10]....뻯] return {initialize finalize watch read} } finalize { @@ -2392,6 +2392,74 @@ test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} { lsort $l } {file1 file2} + +test io-28.6 { + close channel in write event handler + + Should not produce a segmentation fault in a Tcl built with + --enable-symbols and -DPURIFY +} debugpurify { + variable done + variable res + after 0 [list coroutine c1 apply [list {} { + variable done + set chan [chan create w {apply {args { + list initialize finalize watch write configure blocking + }}}] + chan configure $chan -blocking 0 + while 1 { + chan event $chan writable [list [info coroutine]] + yield + close $chan + set done 1 + return + } + } [namespace current]]] + vwait [namespace current]::done +return success +} success + + +test io-28.7 { + close channel in read event handler + + Should not produce a segmentation fault in a Tcl built with + --enable-symbols and -DPURIFY +} debugpurify { + variable done + variable res + after 0 [list coroutine c1 apply [list {} { + variable done + set chan [chan create r {apply {{cmd chan args} { + switch $cmd { + blocking - finalize { + } + watch { + chan postevent $chan read + } + initialize { + list initialize finalize watch read write configure blocking + } + default { + error [list {unexpected command} $cmd] + } + } + }}}] + chan configure $chan -blocking 0 + while 1 { + chan event $chan readable [list [info coroutine]] + yield + close $chan + set done 1 + return + } + } [namespace current]]] + vwait [namespace current]::done +return success +} success + + + test io-29.1 {Tcl_WriteChars, channel not writable} { list [catch {puts stdin hello} msg] $msg } {1 {channel "stdin" wasn't opened for writing}} @@ -5594,7 +5662,7 @@ test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { set x [read $f] close $f set x -} \u7266 +} 牦 test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] @@ -5606,7 +5674,7 @@ test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { set x [read $f] close $f set x -} \u7266 +} 牦 test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { file delete $path(test1) set f [open $path(test1) w] @@ -5749,7 +5817,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats - set x [format "0o%o" [expr {$stats(mode)&0o777}]] + set x [format "%#o" [expr {$stats(mode)&0o777}]] puts $f "line 1" close $f set f [open $path(test3) r] @@ -6079,6 +6147,70 @@ test io-44.5 {FileEventProc procedure: end of file} -constraints { } -result {initial foo eof} close $f + +test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup { +} -constraints {stdio fileevent openpipe} -body { + + namespace eval refchan { + namespace ensemble create + namespace export * + + + proc finalize {chan args} { + namespace delete c_$chan + } + + proc initialize {chan args} { + namespace eval c_$chan {} + namespace upvar c_$chan watching watching + set watching {} + list finalize initialize seek watch write + } + + + proc watch {chan args} { + namespace upvar c_$chan watching watching + foreach arg $args { + switch $arg { + write { + if {$arg ni $watching} { + lappend watching $arg + } + chan postevent $chan $arg + } + } + } + } + + + proc write {chan args} { + chan postevent $chan write + return 1 + } + } + set f [chan create w [namespace which refchan]] + chan configure $f -blocking 0 + set data "some data" + set x 0 + chan event $f writable [namespace code { + puts $f $data + incr count [string length $data] + if {$count > 262144} { + chan event $f writable {} + set x done + } + }] + set token [after 10000 [namespace code { + set x timeout + }]] + vwait [namespace which -variable x] + return $x +} -cleanup { + after cancel $token + catch {chan close $f} +} -result done + + makeFile "foo bar" foo test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { @@ -7262,7 +7394,7 @@ set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] fconfigure $out -encoding koi8-r -translation lf -puts $out "\u0410\u0410" +puts $out "АА" close $out test io-52.9 {TclCopyChannel & encodings} {fcopy} { # Copy kyrillic to UTF-8, using fcopy. @@ -7314,7 +7446,7 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} { test io-52.11 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf - puts $out "\u0410\u0410" + puts $out "АА" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be @@ -8458,7 +8590,7 @@ test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # cut of the remainder of the error stack, especially the filename set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]] list $x $result -} {1 {gets ABC catch {error writing "stdout": invalid argument}}} +} {1 {gets ABC catch {error writing "stdout": illegal byte sequence}}} test io-61.1 {Reset eof state after changing the eof char} -setup { set datafile [makeFile {} eofchar] @@ -8792,7 +8924,7 @@ test io-73.5 {effect of eof on encoding end flags} -setup { read $rfd } -body { set result [eof $rfd] - puts -nonewline $wfd "more\u00C2\u00A0data" + puts -nonewline $wfd "more\xC2\xA0data" lappend result [eof $rfd] lappend result [read $rfd] lappend result [eof $rfd] @@ -8800,7 +8932,7 @@ test io-73.5 {effect of eof on encoding end flags} -setup { close $wfd close $rfd removeFile io-73.5 -} -result [list 1 1 more\u00A0data 1] +} -result [list 1 1 more\xA0data 1] test io-74.1 {[104f2885bb] improper cache validity check} -setup { set fn [makeFile {} io-74.1] @@ -8822,8 +8954,8 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { # The following tests 75.1 to 75.5 exercise strict or tolerant channel # encoding. -# TCL 8.6 only offers tolerant channel encoding, what is tested here. -test io-75.1 {multibyte encoding error read results in raw bytes} -setup { +# TCL 8.7 only offers tolerant channel encoding, what is tested here. +test io-75.1 {multibyte encoding error read results in raw bytes} -constraints deprecated -setup { set fn [makeFile {} io-75.1] set f [open $fn w+] fconfigure $f -encoding binary @@ -8842,7 +8974,7 @@ test io-75.1 {multibyte encoding error read results in raw bytes} -setup { removeFile io-75.1 } -result "41c040" -test io-75.2 {unrepresentable character write passes and is replaced by ?} -setup { +test io-75.2 {unrepresentable character write passes and is replaced by ?} -constraints deprecated -setup { set fn [makeFile {} io-75.2] set f [open $fn w+] fconfigure $f -encoding iso8859-1 @@ -8888,7 +9020,7 @@ test io-75.4 {shiftjis encoding error read results in raw bytes} -setup { flush $f seek $f 0 fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -} -body { +} -constraints deprecated -body { set d [read $f] binary scan $d H* hd set hd |