diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/apply.test | 11 | ||||
| -rw-r--r-- | tests/io.test | 102 | ||||
| -rw-r--r-- | tests/oo.test | 2 | ||||
| -rw-r--r-- | tests/ooNext2.test | 2 | ||||
| -rw-r--r-- | tests/ooUtil.test | 2 | ||||
| -rw-r--r-- | tests/string.test | 12 | ||||
| -rw-r--r-- | tests/winConsole.test | 343 |
7 files changed, 463 insertions, 11 deletions
diff --git a/tests/apply.test b/tests/apply.test index e2be172..a5f1f8f 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -16,12 +16,16 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] if {[info commands ::apply] eq {}} { return } testConstraint memory [llength [info commands memory]] +testConstraint applylambda [llength [info commands testapplylambda]] + # Tests for wrong number of arguments @@ -306,6 +310,13 @@ test apply-9.3 {leaking internal rep} -setup { unset -nocomplain end i x tmp leakedBytes } -result 0 +# Tests for specific bugs +test apply-10.1 {Test for precompiled bytecode body} -constraints { + applylambda +} -body { + testapplylambda +} -result 42 + # Tests for the avoidance of recompilation # cleanup diff --git a/tests/io.test b/tests/io.test index f07fa8d..6314ace 100644 --- a/tests/io.test +++ b/tests/io.test @@ -336,6 +336,15 @@ test io-3.8 {WriteChars: reset sawLF after each buffer} { close $f lappend x [contents $path(test1)] } [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] +test io-3.9 {Write: flush line-buffered channels when crlf is split over two buffers} -body { + # https://core.tcl-lang.org/tcllib/tktedit?name=c9d8a52fe + set f [open $path(test1) w] + fconfigure $f -buffering line -translation crlf -buffersize 8 + puts $f "1234567" + string map {"\r" "<cr>" "\n" "<lf>"} [contents $path(test1)] +} -cleanup { + close $f +} -result "1234567<cr><lf>" test io-4.1 {TranslateOutputEOL: lf} { # search for \n @@ -3067,6 +3076,99 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM interp delete y } "" +test io-29.36.1 {gets on translation auto with "\r" in QA communication mode, possible regression, bug [b3977d199b]} -constraints { + socket tempNotMac fileevent +} -setup { + set s [open "|[list [interpreter] << { + proc accept {so args} { + fconfigure $so -translation binary + puts -nonewline $so "who are you?\r"; flush $so + set a [gets $so] + puts -nonewline $so "really $a?\r"; flush $so + set a [gets $so] + close $so + set ::done $a + } + set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + puts [lindex [fconfigure $s -sockname] 2] + foreach c {1 2} { + vwait ::done + puts $::done + } + }]" r] + set c {} + set result {} +} -body { + set port [gets $s] + foreach t {{cr lf} {auto lf}} { + set c [socket 127.0.0.1 $port] + fconfigure $c -buffering line -translation $t + lappend result $t + while {1} { + set q [gets $c] + switch -- $q { + "who are you?" {puts $c "client"} + "really client?" {puts $c "yes"; lappend result $q; break} + default {puts $c "wrong"; lappend result "unexpected input \"$q\""; break} + } + } + lappend result [gets $s] + close $c; set c {} + } + set result +} -cleanup { + close $s + if {$c ne {}} { close $c } + unset -nocomplain s c port t q +} -result [list {cr lf} "really client?" yes {auto lf} "really client?" yes] +test io-29.36.2 {gets on translation auto with "\r\n" in different buffers, bug [b3977d199b]} -constraints { + socket tempNotMac fileevent +} -setup { + set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] + set c {} +} -body { + set ::cnt 0 + proc accept {so args} { + fconfigure $so -translation binary + puts -nonewline $so "1 line\r" + puts -nonewline $so "\n2 li" + flush $so + # now force separate packets + puts -nonewline $so "ne\r" + flush $so + if {$::cnt & 1} { + vwait ::cli; # simulate short delay (so client can process events, just wait for it) + } else { + # we don't have a delay, so client would get the lines as single chunk + } + # we'll try with "\r" and without "\r" (to cover both branches, where "\r" and "eof" causes exit from [gets] by 3rd line) + puts -nonewline $so "\n3 line" + if {!($::cnt % 3)} { + puts -nonewline $so "\r" + } + flush $so + close $so + } + while {$::cnt < 6} { incr ::cnt + set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + fconfigure $c -blocking 0 -buffering line -translation auto + fileevent $c readable [list apply {c { + if {[gets $c line] >= 0} { + lappend ::cli <$line> + } elseif {[eof $c]} { + set ::done 1 + } + }} $c] + vwait ::done + close $c; set c {} + } + set ::cli +} -cleanup { + close $s + if {$c ne {}} { close $c } + unset -nocomplain ::done ::cli ::cnt s c +} -result [lrepeat 6 {<1 line>} {<2 line>} {<3 line>}] + # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. test io-30.1 {Tcl_Write lf, Tcl_Read lf} { diff --git a/tests/oo.test b/tests/oo.test index 105c492..ff67cc1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.2.0 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooNext2.test b/tests/ooNext2.test index ce4acdf..746f9a5 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.2.0 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 4db971e..c8be9c8 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl::oo 1.2.0 +package require tcl::oo 1.3.0 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/string.test b/tests/string.test index d497b42..ba5be14 100644 --- a/tests/string.test +++ b/tests/string.test @@ -34,6 +34,7 @@ testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint testutf16string [llength [info commands testutf16string]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -2635,6 +2636,17 @@ test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { } 0 }; # foreach noComp {0 1} + +test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints { + testutf16string deprecated +} -body { + # This simple test suffices because the bug has nothing to do with + # the actual encoding conversion. The test was added because these + # functions are no longer called within the Tcl core and thus + # not tested by either `string`, not `encoding` tests. + testutf16string "abcde" +} -result abcde + # cleanup rename MemStress {} diff --git a/tests/winConsole.test b/tests/winConsole.test index 8ca1457..821a143 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -14,34 +14,361 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +catch {package require twapi} ;# Only to bring window to foreground. Not critical -test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} { - set oldmode [fconfigure stdin] +::tcltest::ConstraintInitializer haveThread { expr {![catch {package require Thread}]} } + +# Prompt user for a yes/no response +proc yesno {question {default "Y"}} { + set answer "" + # Make sure we are seen but catch because ui and console + # packages may not be available + catch {twapi::set_foreground_window [twapi::get_console_window]} + while {![string is boolean -strict $answer]} { + puts -nonewline stdout "$question Type Y/N followed by Enter \[$default\] : " + flush stdout + set answer [string trim [gets stdin]] + if {$answer eq ""} { + set answer $default + } + } + return [expr {!! $answer}] +} - puts stdout "Enter abcdef<return> now: " nonewline +proc prompt {prompt} { + # Make sure we are seen but catch because twapi ui and console + # packages may not be available + catch {twapi::set_foreground_window [twapi::get_console_window]} + puts -nonewline stdout "$prompt" flush stdout +} + +# Input tests + +test console-input-1.0 {Console blocking gets} -constraints {win interactive} -body { + prompt "Type \"xyz\" and hit Enter: " + gets stdin +} -result xyz + +test console-input-1.1 {Console file channel: non-blocking gets} -constraints { + win interactive +} -setup { + unset -nocomplain result + unset -nocomplain result2 +} -body { + set oldmode [fconfigure stdin] + + prompt "Type \"abc\" and hit Enter: " fileevent stdin readable { if {[gets stdin line] >= 0} { - set result $line - } else { + lappend result2 $line + if {[llength $result2] > 1} { + set result $result2 + } else { + prompt "Type \"def\" and hit Enter: " + } + } elseif {[eof stdin]} { set result "gets failed" } } fconfigure stdin -blocking 0 -buffering line - set result {} vwait result #cleanup the fileevent fileevent stdin readable {} fconfigure stdin {*}$oldmode + set result + +} -result {abc def} + +test console-input-1.1.1 {Bug baa51423c28a: Console file channel: fileevent with blocking gets} -constraints { + win interactive +} -setup { + unset -nocomplain result + unset -nocomplain result2 +} -body { + prompt "Type \"abc\" and hit Enter: " + fileevent stdin readable { + if {[gets stdin line] >= 0} { + lappend result2 $line + if {[llength $result2] > 1} { + set result $result2 + } else { + prompt "Type \"def\" and hit Enter: " + } + } elseif {[eof stdin]} { + set result "gets failed" + } + } + + vwait result + #cleanup the fileevent + fileevent stdin readable {} + set result + +} -result {abc def} + +test console-input-2.0 {Console blocking read} -constraints {win interactive} -setup { + set oldmode [fconfigure stdin] + fconfigure stdin -inputmode raw +} -cleanup { + fconfigure stdin {*}$oldmode +} -body { + prompt "Type the key \"a\". Do NOT hit Enter. You will NOT see characters echoed." + set c [read stdin 1] + puts "" + set c +} -result a + +test console-input-2.1 {Console file channel: non-blocking read} -constraints { + win interactive +} -setup { + set oldmode [fconfigure stdin] +} -cleanup { + fconfigure stdin {*}$oldmode + puts ""; # Because CRLF also would not have been echoed +} -body { + set input "" + fconfigure stdin -blocking 0 -buffering line -inputmode raw + prompt "Type \"abc\". Do NOT hit Enter. You will NOT see characters echoed." + + fileevent stdin readable { + set c [read stdin 1] + if {$c eq ""} { + if {[eof stdin]} { + set result "read eof" + } + } else { + append input $c + if {[string length $input] == 3} { + set result $input + } + } + } + + set result {} + vwait result + fileevent stdin readable {} set result +} -result abc + +# Output tests + +test console-output-1.0 {Console blocking puts stdout} -constraints {win interactive} -body { + puts stdout "123" + yesno "Did you see the string \"123\"?" +} -result 1 + +test console-output-1.1 {Console non-blocking puts stdout} -constraints { + win interactive +} -setup { + set oldmode [fconfigure stdout] + dict unset oldmode -winsize +} -cleanup { + fconfigure stdout {*}$oldmode +} -body { + fconfigure stdout -blocking 0 -buffering line + set count 0 + fileevent stdout writable { + if {[incr count] < 4} { + puts "$count" + } else { + fileevent stdout writable {} + set done 1 + } + } + vwait done + yesno "Did you see 1, 2, 3 printed on consecutive lines?" +} -result 1 + +test console-output-2.0 {Console blocking puts stderr} -constraints {win interactive} -body { + puts stderr "456" + yesno "Did you see the string \"456\"?" +} -result 1 + + +# fconfigure get tests + +## fconfigure get stdin + +test console-fconfigure-get-1.0 { + Console get stdin configuration +} -constraints {win interactive} -body { + lsort [dict keys [fconfigure stdin]] +} -result {-blocking -buffering -buffersize -encoding -eofchar -inputmode -translation} + +set testnum 0 +foreach {opt result} { + -blocking 1 + -buffering line + -buffersize 4096 + -encoding utf-16 + -inputmode normal + -translation auto +} { + test console-fconfigure-get-1.[incr testnum] "Console get stdin option $opt" \ + -constraints {win interactive} -body { + fconfigure stdin $opt + } -result $result +} +test console-fconfigure-get-1.[incr testnum] { + Console get stdin option -eofchar +} -constraints {win interactive} -body { + fconfigure stdin -eofchar +} -result \x1a + +test console-fconfigure-get-1.[incr testnum] { + fconfigure -winsize +} -constraints {win interactive} -body { + fconfigure stdin -winsize +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error + +## fconfigure get stdout/stderr +foreach chan {stdout stderr} major {2 3} { + test console-fconfigure-get-$major.0 "Console get $chan configuration" -constraints { + win interactive + } -body { + lsort [dict keys [fconfigure $chan]] + } -result {-blocking -buffering -buffersize -encoding -eofchar -translation -winsize} + set testnum 0 + foreach {opt result} { + -blocking 1 + -buffersize 4096 + -encoding utf-16 + -translation crlf + } { + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option $opt" \ + -constraints {win interactive} -body { + fconfigure $chan $opt + } -result $result + } + + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -winsize" \ + -constraints {win interactive} -body { + fconfigure $chan -winsize + } -result {\d+ \d+} -match regexp + + test console-fconfigure-get-$major.[incr testnum] "Console get $chan option -buffering" \ + -constraints {win interactive} -body { + fconfigure $chan -buffering + } -result [expr {$chan eq "stdout" ? "line" : "none"}] + + test console-fconfigure-get-$major.[incr testnum] { + fconfigure -inputmode + } -constraints {win interactive} -body { + fconfigure $chan -inputmode + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error + +} + +## fconfigure set stdin + +test console-fconfigure-set-1.0 { + fconfigure -inputmode password +} -constraints {win interactive} -body { + set result {} + + prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode password + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode normal + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type \"norm\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed?"] + + set result +} -result [list pass password 0 norm normal 1] + +test console-fconfigure-set-1.1 { + fconfigure -inputmode raw +} -constraints {win interactive} -body { + set result {} + + prompt "Type the keys \"a\", Ctrl-H, \"b\". Do NOT hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode raw + lappend result [read stdin 3] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode normal + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type the keys \"c\", Ctrl-H, \"d\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed (c replaced by d)?"] + + set result +} -result [list a\x08b raw 0 d normal 1] + +test console-fconfigure-set-1.2 { + fconfigure -inputmode reset +} -constraints {win interactive} -body { + set result {} + + prompt "Type \"pass\" and hit Enter. You should NOT see characters echoed: " + fconfigure stdin -inputmode password + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + fconfigure stdin -inputmode reset + lappend result [yesno "\nWere the characters echoed?"] + + prompt "Type \"reset\" and hit Enter. You should see characters echoed: " + lappend result [gets stdin] + lappend result [fconfigure stdin -inputmode] + lappend result [yesno "Were the characters echoed?"] + + set result +} -result [list pass password 0 reset normal 1] + +test console-fconfigure-set-1.3 { + fconfigure stdin -winsize +} -constraints {win interactive} -body { + fconfigure stdin -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error + +## fconfigure set stdout,stderr + +test console-fconfigure-set-2.0 { + fconfigure stdout -winsize +} -constraints {win interactive} -body { + fconfigure stdout -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error + +test console-fconfigure-set-3.0 { + fconfigure stderr -winsize +} -constraints {win interactive} -body { + fconfigure stderr -winsize {10 30} +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error + +# Multiple threads -} "abcdef" +test console-thread-input-1.0 {Get input in thread} -constraints { + win interactive haveThread +} -setup { + set tid [thread::create] +} -cleanup { + thread::release $tid +} -body { + prompt "Type \"xyz\" and hit Enter: " + thread::send $tid {gets stdin} +} -result xyz -#cleanup +test console-thread-output-1.0 {Output from thread} -constraints { + win interactive haveThread +} -setup { + set tid [thread::create] +} -cleanup { + thread::release $tid +} -body { + thread::send $tid {puts [thread::id]} + yesno "Did you see $tid printed?" +} -result 1 ::tcltest::cleanupTests return |