# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# 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.45.2.6 2004/05/27 14:29:19 dgp Exp $
# RCS: @(#) $Id: io.test,v 1.45.2.7 2004/09/08 23:03:18 dgp Exp $

if {[catch {package require tcltest 2}]} {
    puts stderr "Skipping tests in [info script].  tcltest 2 required."
    return
}
namespace eval ::tcl::test::io {

    close $f2
    set result
} {{
out
} {err
}}
# This test relies on the fact that the smallest available fd is used first.
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unixOnly} {
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unix} {
    set f [open $path(test1) w]
    puts -nonewline $f { close stdin
	close stdout
	close stderr
	set f  [}
    puts $f [list open $path(test1) r]]
    puts $f "set f2 \[[list open $path(test2) w]]"

    lappend l [expr [testchannel refcount stderr] - $l1]
    interp delete x
    lappend l [expr [testchannel refcount stderr] - $l1]
    set l
} {0 1 0}

test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    file delete $path(test1)
    file delete -force $path(test1)
    set l ""
    set f [open $path(test1) w]
    lappend l [lindex [testchannel info $f] 15]
    close $f
    if {[catch {lindex [testchannel info $f] 15} msg]} {
	lappend l $msg
    } else {
	lappend l "very broken: $f found after being closed"
    }
    string compare [string tolower $l] \
	[list 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    file delete $path(test1)
    file delete -force $path(test1)
    set l ""
    set f [open $path(test1) w]
    lappend l [lindex [testchannel info $f] 15]
    interp create x
    interp share "" $f x
    lappend l [lindex [testchannel info $f] 15]
    x eval close $f

    set f [open $path(test1) w]
    set x [fconfigure $f -encoding]
    close $f
    encoding system $old
	close $a
    set x
} {ascii}    
test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
test io-20.2 {Tcl_CreateChannel: initial settings} {win} {
    set f [open $path(test1) w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
test io-20.3 {Tcl_CreateChannel: initial settings} {unix} {
    set f [open $path(test1) w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto lf}}

set path(stdout) [makeFile {} stdout]

    close $f
    set f [open "|[list [interpreter] $path(pipe)]" w]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 65536) && ($counter < 1000)} {
        incr counter
        after 20
	after 20 [list incr [namespace which -variable counter]]
        update
	vwait [namespace which -variable counter]
    }
    if {$counter == 1000} {
        set result "file size only [file size $path(output)]"
    } else {
        set result ok
    }
} ok

    set f [open "|[list [interpreter] pipe]" r+]
    fconfigure $f -blocking off -eofchar {}

    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 20480) && ($counter < 1000)} {
        incr counter
        after 20
	after 20 [list incr [namespace which -variable counter]]
        update
	vwait [namespace which -variable counter]
    }
    if {$counter == 1000} {
        set result probably_broken
    } else {
        set result ok
    }
} ok
test io-28.4 {Tcl_Close} {testchannel} {
    file delete $path(test1)
    set l ""
    lappend l [lsort [testchannel open]]
    set f [open $path(test1) w]
    lappend l [lsort [testchannel open]]
    close $f
    lappend l [lsort [testchannel open]]
    set x [list $consoleFileNames \
		[lsort [list {expand}$consoleFileNames $f]] \
		$consoleFileNames]
    string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel openpipe} {
test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel openpipe} {
    file delete $path(script)
    set f [open $path(script) w]
    puts $f {
	close stdin
	puts [testchannel open]
    }
    close $f

    close $f
    set f [open "|[list [interpreter] $path(pipe)]" r+]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 65536) && ($counter < 1000)} {
	after 10 [list incr [namespace which -variable counter]]
	incr counter
	vwait [namespace which -variable counter]
	after 5
	update
    }
    if {$counter == 1000} {
	set result "file size only [file size $path(output)]"
    } else {
	set result ok
    }
    # allow a little time for the background process to close.
    # otherwise, the following test fails on the [file delete $path(output)
    # on Windows because a process still has the file open.
    after 100 set v 1; vwait v
    set result
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
	{stdio asyncPipeClose openpipe} {
    file delete $path(pipe)
    file delete $path(output)
    set f [open $path(pipe) w]
    puts $f "set f \[[list open $path(output) w]]"

    close $f
    set f [open "|[list [interpreter] $path(pipe)]" r+]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 65536) && ($counter < 1000)} {
	incr counter
	after 20
	after 20 [list incr [namespace which -variable counter]]
	update
	vwait [namespace which -variable counter]
    }
    if {$counter == 1000} {
	set result "file size only [file size $path(output)]"
    } else {
	set result ok
    }
} ok

    close $f
    set c
} {hello
there
and
here
}
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} {
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} {
    file delete $path(test1)
    set f [open $path(test1) w]
    fconfigure $f -eofchar \x1a -translation lf
    puts $f hello\nthere\nand\rhere
    close $f
    set f [open $path(test1) r]
    fconfigure $f -eofchar \x1a -translation auto

    fconfigure $s2 -translation {auto auto}
    set modes [fconfigure $s2 -translation]
    close $s1
    close $s2
    set modes
} {auto crlf}

test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
test io-39.22 {Tcl_SetChannelOption, invariance} {unix} {
    file delete $path(test1)
    set f1 [open $path(test1) w+]
    set l ""
    lappend l [fconfigure $f1 -eofchar]
    fconfigure $f1 -eofchar {ON GO}
    lappend l [fconfigure $f1 -eofchar]
    fconfigure $f1 -eofchar D

    set x [gets $f]
    close $f
    set f [open $path(test3) r]
    lappend x [gets $f]
    close $f
    set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unixOnly} {
test io-40.2 {POSIX open access modes: CREAT} {unix} {
    file delete $path(test3)
    set f [open $path(test3) {WRONLY CREAT} 0600]
    file stat $path(test3) stats
    set x [format "0%o" [expr $stats(mode)&0777]]
    puts $f "line 1"
    close $f
    set f [open $path(test3) r]
    lappend x [gets $f]
    close $f
    set x
} {0600 {line 1}}

# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
catch {testConstraint umask2 [expr {[exec umask] == 2}]}

test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} {
test io-40.3 {POSIX open access modes: CREAT} {unix umask2} {
    # This test only works if your umask is 2, like ouster's.
    file delete $path(test3)
    set f [open $path(test3) {WRONLY CREAT}]
    close $f
    file stat test3 stats
    format "0%o" [expr $stats(mode)&0777]
} 0664

    puts $f abc
    close $f
    set f [open $path(test3) r]
    set x [gets $f]
    close $f
    set x
} abc
test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable unixOnly} {
test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable unix} {
    file delete $path(test3)
    set f [open $path(test3) {WRONLY NONBLOCK CREAT}]
    puts $f "NONBLOCK test"
    close $f
    set f [open $path(test3) r]
    set x [gets $f]
    close $f

    variable x not_done
    vwait [namespace which -variable x]
    list $x $l
} {done {called called called called called called called}}

set path(my_script) [makeFile {} my_script]

test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles openpipe fileevent} {
test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} {
    set f [open $path(bar) w]
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    puts $f abcdefg
    close $f

    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
    }
    set result
} {0 0 ok}
test io-53.3 {CopyData: background read underflow} {stdio unixOnly openpipe fcopy} {
test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} {
    file delete $path(test1)
    file delete $path(pipe)
    set f1 [open $path(pipe) w]
    puts -nonewline $f1 {
	puts ready
	flush stdout				;# Don't assume line buffered!
	fcopy stdin stdout -command { set x }

    close $f1
    after 500
    set f [open $path(test1)]
    lappend result [read $f]
    close $f
    set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio unixOnly openpipe fileevent fcopy} {
test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} {
    set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
    variable x
    for {set x 0} {$x < 12} {incr x} {
	append big $big
    }
    file delete $path(test1)
    file delete $path(pipe)

    vwait [namespace which -variable x]

    # 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 {} catch {error writing "stdout": invalid argument}}}

set datafile [file join $::tcltest::testsDirectory eofchar.data]

test io-61.1 {Reset eof state after changing the eof char} {
test io-61.1 {Reset eof state after changing the eof char} -setup {
    set datafile [makeFile {} eofchar]
    set f [open $datafile w]
    fconfigure $f -translation binary
    puts -nonewline $f [string repeat "Ho hum\n" 11]
    puts $f =
    set line [string repeat "Ge gla " 4]
    puts -nonewline $f [string repeat [string trimright $line]\n 834]
    close $f
} -body {
    set f [open $datafile r]
    fconfigure $f -eofchar =
    set res {}
    lappend res [read $f; tell $f]
    fconfigure $f -eofchar {}
    lappend res [read $f 1]
    lappend res [read $f; tell $f]
    # Any seek zaps the internals into a good state.
    #seek $f 0 start
    #seek $f 0 current
    #lappend res [read $f; tell $f]
    close $f
    set res
} -cleanup {
    removeFile eofchar
} {77 = 23431}
} -result {77 = 23431}


# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
	bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
    removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return