io.test

tcl是工具命令语言

test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
    set l1 [testchannel refcount stdout]
    eof stdin
    interp create x
    set l ""
    lappend l [expr [testchannel refcount stdout] - $l1]
    x eval {eof stdout}
    lappend l [expr [testchannel refcount stdout] - $l1]
    interp delete x
    lappend l [expr [testchannel refcount stdout] - $l1]
    set l
} {0 1 0}
test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
    set l1 [testchannel refcount stderr]
    eof stdin
    interp create x
    set l ""
    lappend l [expr [testchannel refcount stderr] - $l1]
    x eval {eof stderr}
    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} {
    removeFile 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} {
    removeFile 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
    lappend l [lindex [testchannel info $f] 15]
    interp delete x
    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 2 1 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
    removeFile 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]
    interp delete x
    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 2 1 [format "can not find channel named \"%s\"" $f]]
} 0

test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
    eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
    removeFile test1
    set f [open $path(test1) w]
    set x [eof $f]
    close $f
    set x
} 0
test io-19.3 {Tcl_GetChannel, channel not found} {
    list [catch {eof file34} msg] $msg
} {1 {can not find channel named "file34"}}
test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    set l ""
    lappend l [eof $f]
    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 0 [format "can not find channel named \"%s\"" $f]]
} 0

test io-20.1 {Tcl_CreateChannel: initial settings} {
	set a [open $path(test2) w]
    set old [encoding system]
    encoding system ascii
    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} {
    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} {
    set f [open $path(test1) w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} {
    set f [open $path(test1) w+]
    set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
    close $f
    set x
} {{{} {}} {auto cr}}

set path(stdout) [makeFile {} stdout]

test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} {
    set f [open $path(script) w]
    puts $f [format {
	close stdout
	set f1 [open "%s" w]
	fconfigure $f1 -buffersize 777
	puts stderr [fconfigure stdout -buffersize]
    } $path(stdout)]
    close $f
    set f [open "|[list [interpreter] $path(script)]"]
    catch {close $f} msg
    set msg
} {777}
	
test io-21.1 {CloseChannelsOnExit} {
} {}
    
# Test management of attributes associated with a channel, such as
# its default translation, its name and type, etc. The functions
# tested in this group are Tcl_GetChannelName,
# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData
# not tested because files do not use the instance data.

test io-22.1 {Tcl_GetChannelMode} {
    # Not used anywhere in Tcl.
} {}

test io-23.1 {Tcl_GetChannelName} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    set n [testchannel name $f]
    close $f
    string compare $n $f
} 0

test io-24.1 {Tcl_GetChannelType} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    set t [testchannel type $f]
    close $f
    string compare $t file
} 0

test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    puts $f "1234567890\n098765432"
    close $f
    set f [open $path(test1) r]
    gets $f
    set l ""
    lappend l [testchannel inputbuffered $f]
    lappend l [tell $f]
    close $f
    set l
} {10 11}
test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf
    puts $f hello
    set l ""
    lappend l [testchannel outputbuffered $f]
    lappend l [tell $f]
    flush $f
    lappend l [testchannel outputbuffered $f]
    lappend l [tell $f]
    close $f
    removeFile test1
    set l
} {6 6 0 6}

test io-26.1 {Tcl_GetChannelInstanceData} {stdio} {
    # "pid" command uses Tcl_GetChannelInstanceData
    # Don't care what pid is (but must be a number), just want to exercise it.

    set f [open "|[list [interpreter] << exit]"]
    expr [pid $f]
    close $f
} {}    

# Test flushing. The functions tested here are FlushChannel.

test io-27.1 {FlushChannel, no output buffered} {
    removeFile test1
    set f [open $path(test1) w]
    flush $f
    set s [file size $path(test1)]
    close $f
    set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    puts $f hello
    lappend l [file size $path(test1)]
    flush $f
    lappend l [file size $path(test1)]
    close $f
    lappend l [file size $path(test1)]
    set l
} {0 6 6}
test io-27.3 {FlushChannel, implicit flush on close} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    set l ""
    puts $f hello
    lappend l [file size $path(test1)]
    close $f
    lappend l [file size $path(test1)]
    set l
} {0 6}
test io-27.4 {FlushChannel, implicit flush when buffer fills} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -eofchar {}
    fconfigure $f -buffersize 60
    set l ""
    lappend l [file size $path(test1)]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size $path(test1)]
    flush $f
    lappend l [file size $path(test1)]
    close $f
    set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
	{unixOrPc} {
    removeFile test1
    set f [open $path(test1) w]
    fconfigure $f -translation lf -buffersize 60 -eofchar {}
    set l ""
    lappend l [file size $path(test1)]
    for {set i 0} {$i < 12} {incr i} {
	puts $f hello
    }
    lappend l [file size $path(test1)]
    close $f
    lappend l [file size $path(test1)]
    set l
} {0 60 72}

set path(pipe)   [makeFile {} pipe]
set path(output) [makeFile {} output]

test io-27.6 {FlushChannel, async flushing, async close} \
	{stdio asyncPipeClose } {
    removeFile pipe
    removeFile output
    set f [open $path(pipe) w]
    puts $f [format {
	set f [open "%s" w]
	fconfigure $f -translation lf -buffering none -eofchar {}
	while {![eof stdin]} {
	    after 20
	    puts -nonewline $f [read stdin 1024]
	}
	close $f
    } $path(output)]
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
        set x "$x$x"
    }
    set f [open $path(output) w]
    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
        update
    }
    if {$counter == 1000} {
        set result "file size only [file size $path(output)]"
    } else {
        set result ok
    }
} ok

# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.

test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
    removeFile test1
    set f [open $path(test1) w]
    interp create x
    interp share "" $f x
    set l ""
    lappend l [testchannel refcount $f]
    x eval close $f
    interp delete x
    lappend l [testchannel refcount $f]
    close $f
    set l
} {2 1}
test io-28.2 {CloseChannel called when all references are dropped} {
    removeFile test1
    set f [open $path(test1) w]
    interp create x
    interp share "" $f x
    puts -nonewline $f abc
    close $f
    x eval puts $f def
    x eval close $f
    interp delete x
    set f [open $path(test1) r]
    set l [gets $f]
    close $f
    set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
	{stdio asyncPipeClose nonPortable} {
    removeFile pipe
    removeFile output
    set f [open $path(pipe) w]
    puts $f {

	# Need to not have eof char appended on close, because the other
	# side of the pipe already closed, so that writing would cause an
	# error "invalid file".

	fconfigure stdout -eofchar {}
	fconfigure stderr -eofchar {}

	set f [open $path(output) w]
	fconfigure $f -translation lf -buffering none
	for {set x 0} {$x < 20} {incr x} {
	    after 20
	    puts -nonewline $f [read stdin 1024]
	}
	close $f
    }
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
        set x "$x$x"
    }
    set f [open $path(output) w]
    close $f
    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
        update
    }
    if {$counter == 1000} {
        set result probably_broken
    } else {
        set result ok
    }
} ok
test io-28.4 {Tcl_Close} {testchannel} {
    removeFile 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 [eval list $consoleFileNames $f]] \
		$consoleFileNames]
    string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel} {
    removeFile script
    set f [open $path(script) w]
    puts $f {
	close stdin
	puts [testchannel open]
    }
    close $f
    set f [open "|[list [interpreter] $path(script)]" r]
    set l [gets $f]
    close $f
    set l
} {file1 file2}

test io-29.1 {Tcl_WriteChars, channel not w