diff options
Diffstat (limited to 'tests/io.test')
| -rw-r--r-- | tests/io.test | 96 |
1 files changed, 13 insertions, 83 deletions
diff --git a/tests/io.test b/tests/io.test index 68051d7..0ab8909 100644 --- a/tests/io.test +++ b/tests/io.test @@ -12,6 +12,8 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: io.test,v 1.93 2008/12/19 17:07:47 dgp Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -2086,8 +2088,6 @@ set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] test io-27.6 {FlushChannel, async flushing, async close} \ {stdio asyncPipeClose openpipe} { - # This test may fail on old Unix systems (seen on IRIX64 6.5) with - # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -2647,8 +2647,6 @@ test io-29.30 {Tcl_WriteChars, crlf mode} { file size $path(test1) } 25 test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { - # This test may fail on old Unix systems (seen on IRIX64 6.5) with - # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -2690,8 +2688,6 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { } ok test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ {stdio asyncPipeClose openpipe} { - # This test may fail on old Unix systems (seen on IRIX64 6.5) with - # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -3862,7 +3858,7 @@ test io-32.3 {Tcl_Read, negative byte count} { set l [list [catch {read $f -1} msg] $msg] close $f set l -} {1 {expected non-negative integer but got "-1"}} +} {1 {bad argument "-1": should be "nonewline"}} test io-32.4 {Tcl_Read, positive byte count} { set f [open $path(longfile) r] set x [read $f 1024] @@ -5211,16 +5207,16 @@ test io-40.1 {POSIX open access modes: RDWR} { } {zzy abzzy} test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) - set f [open $path(test3) {WRONLY CREAT} 0o600] + set f [open $path(test3) {WRONLY CREAT} 0600] file stat $path(test3) stats - set x [format "0o%o" [expr $stats(mode)&0o777]] + set x [format "0%o" [expr $stats(mode)&0o777]] puts $f "line 1" close $f set f [open $path(test3) r] lappend x [gets $f] close $f set x -} {0o600 {line 1}} +} {0600 {line 1}} test io-40.3 {POSIX open access modes: CREAT} {unix umask} { # This test only works if your umask is 2, like ouster's. file delete $path(test3) @@ -6579,7 +6575,7 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { } set result } {0 0 ok} -test io-52.5b {TclCopyChannel, all, wrapped to negative value} {fcopy} { +test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] @@ -7011,44 +7007,6 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} removeFile foo removeFile bar } -result {1 sync/OK {CMD 0}} -test io-53.8b {CopyData: async callback and -size 0} -setup { - # copy progress callback. errors out intentionally - proc ::cmd args { - lappend ::RES "CMD $args" - set ::forever has-been-reached - return - } - # Files we use for our channels - set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] - set bar [makeFile {} bar] - # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { - set ::RES {} - # Run the copy. Should not invoke -command now. - fcopy $f $g -size 0 -command ::cmd - # Check that -command was not called synchronously - lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] - # Now let the async part happen. Should capture the eof in cmd - # If not break the event loop via timer. - set token [after 1000 { - lappend ::RES {cmd/FAIL timeout} - set ::forever has-been-reached - }] - vwait ::forever - catch {after cancel $token} - # Report - set ::RES -} -cleanup { - close $f - close $g - catch {unset ::RES} - catch {unset ::forever} - rename ::cmd {} - removeFile foo - removeFile bar -} -result {sync/OK {CMD 0}} test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { set out [makeFile {} out] set err [makeFile {} err] @@ -7168,37 +7126,6 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { removeFile err catch {unset ::forever} } -result {AB BA} -test io-53.11 {Bug 2895565} -setup { - set in [makeFile {} in] - set f [open $in w] - fconfigure $f -encoding utf-8 -translation binary - puts -nonewline $f [string repeat "Ho hum\n" 11] - close $f - set inChan [open $in r] - fconfigure $inChan -translation binary - set out [makeFile {} out] - set outChan [open $out w] - fconfigure $outChan -encoding cp1252 -translation crlf - proc CopyDone {bytes args} { - variable done - if {[llength $args]} { - set done "Error: '[lindex $args 0]' after $bytes bytes copied" - } else { - set done "$bytes bytes copied" - } - } -} -body { - variable done - after 2000 [list set [namespace which -variable done] timeout] - fcopy $inChan $outChan -size 40 -command [namespace which CopyDone] - vwait [namespace which -variable done] - set done -} -cleanup { - close $outChan - close $inChan - removeFile out - removeFile in -} -result {40 bytes copied} test io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive @@ -7768,15 +7695,18 @@ test io-73.1 {channel Tcl_Obj SetChannelFromAny} {} { catch {close [lreplace [list a] 0 end]} } {1} -test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} {} { +test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup { # Invalidate intrep of 'channel' Tcl_Obj when transiting between interpreters. - interp create foo set f [open [info script] r] +} -body { + interp create foo seek $f 0 set code [catch {interp eval foo [list seek $f 0]} msg] # The string map converts the changing channel handle to a fixed string list $code [string map [list $f @@] $msg] -} {1 {can not find channel named "@@"}} +} -cleanup { + close $f +} -result {1 {can not find channel named "@@"}} # ### ### ### ######### ######### ######### |