summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/append.test17
-rw-r--r--tests/appendComp.test21
-rw-r--r--tests/fileSystem.test3
-rw-r--r--tests/interp.test4
-rw-r--r--tests/io.test20
-rw-r--r--tests/ioTrans.test173
-rw-r--r--tests/iogt.test74
-rw-r--r--tests/oo.test2
-rw-r--r--tests/ooNext2.test2
-rw-r--r--tests/parse.test8
-rw-r--r--tests/parseOld.test12
-rw-r--r--tests/socket.test2
-rw-r--r--tests/subst.test4
-rw-r--r--tests/utf.test40
-rw-r--r--tests/winFCmd.test13
15 files changed, 355 insertions, 40 deletions
diff --git a/tests/append.test b/tests/append.test
index 69c6381..8fa4e61 100644
--- a/tests/append.test
+++ b/tests/append.test
@@ -292,6 +292,23 @@ test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env
} -cleanup {
unset -nocomplain ::env(__DUMMY__)
} -result {0 {new value}}
+
+test append-10.1 {Bug 214cc0eb22: lappend with no values} {
+ set lst "# 1 2 3"
+ [subst lappend] lst
+} "# 1 2 3"
+test append-10.2 {Bug 214cc0eb22: lappend with no values} -body {
+ set lst "1 \{ 2"
+ [subst lappend] lst
+} -returnCodes error -result {unmatched open brace in list}
+test append-10.3 {Bug 214cc0eb22: expanded lappend with no values} {
+ set lst "# 1 2 3"
+ [subst lappend] lst {*}[list]
+} "# 1 2 3"
+test append-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body {
+ set lst "1 \{ 2"
+ [subst lappend] lst {*}[list]
+} -returnCodes error -result {unmatched open brace in list}
unset -nocomplain i x result y
catch {rename foo ""}
diff --git a/tests/appendComp.test b/tests/appendComp.test
index f85c3ba..bbf5f9c 100644
--- a/tests/appendComp.test
+++ b/tests/appendComp.test
@@ -438,6 +438,27 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing
} -cleanup {
unset -nocomplain ::env(__DUMMY__)
} -result {0 {new value}}
+
+test appendComp-10.1 {Bug 214cc0eb22: lappend with no values} {
+ apply {lst {
+ lappend lst
+ }} "# 1 2 3"
+} "# 1 2 3"
+test appendComp-10.2 {Bug 214cc0eb22: lappend with no values} -body {
+ apply {lst {
+ lappend lst
+ }} "1 \{ 2"
+} -returnCodes error -result {unmatched open brace in list}
+test appendComp-10.3 {Bug 214cc0eb22: expanded lappend with no values} {
+ apply {lst {
+ lappend lst {*}[list]
+ }} "# 1 2 3"
+} "# 1 2 3"
+test appendComp-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body {
+ apply {lst {
+ lappend lst {*}[list]
+ }} "1 \{ 2"
+} -returnCodes error -result {unmatched open brace in list}
catch {unset i x result y}
catch {rename foo ""}
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 942a86c..9fe4fe9 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -513,6 +513,9 @@ test filesystem-6.32 {empty file name} -returnCodes error -body {
file type ""
} -result {could not read "": no such file or directory}
test filesystem-6.33 {empty file name} {file writable ""} 0
+test filesystem-6.34 {file name with (invalid) nul character} {
+ list [catch "open foo\x00" msg] $msg
+} [list 1 "couldn't open \"foo\x00\": filename is invalid on this platform"]
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
diff --git a/tests/interp.test b/tests/interp.test
index ad99fac..4bc9fe2 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -3615,10 +3615,10 @@ test interp-38.3 {interp debug wrong args} -body {
} -returnCodes {
error
} -result {wrong # args: should be "interp debug path ?-frame ?bool??"}
-test interp-38.4 {interp debug basic setup} -body {
+test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body {
interp debug {}
} -result {-frame 0}
-test interp-38.5 {interp debug basic setup} -body {
+test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body {
interp debug {} -f
} -result {0}
test interp-38.6 {interp debug basic setup} -body {
diff --git a/tests/io.test b/tests/io.test
index 33f91bd..b09d55a 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -8465,6 +8465,26 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup {
close $f
} -result {1 {can not find channel named "@@"}}
+test io-73.3 {[5adc350683] [gets] after EOF} -setup {
+ set fn [makeFile {} io-73.3]
+ set rfd [open $fn r]
+ set wfd [open $fn a]
+ chan configure $wfd -buffering line
+ read $rfd
+} -body {
+ set result [eof $rfd]
+ puts $wfd "more data"
+ lappend result [eof $rfd]
+ lappend result [gets $rfd]
+ lappend result [eof $rfd]
+ lappend result [gets $rfd]
+ lappend result [eof $rfd]
+} -cleanup {
+ close $wfd
+ close $rfd
+ removeFile io-73.3
+} -result {1 1 {more data} 0 {} 1}
+
# ### ### ### ######### ######### #########
# cleanup
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 53078f7..e179eab 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -598,6 +598,179 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
} -result {{read rt* {test data
}} {}}
+# Driver for a base channel that emits several short "files"
+# with each terminated by a fleeting EOF
+ proc driver {cmd args} {
+ variable ::tcl::buffer
+ variable ::tcl::index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) .....
+ return {initialize finalize watch read}
+ }
+ finalize {
+ if {![info exists index($chan)]} {return}
+ unset index($chan) buffer($chan)
+ array unset index
+ array unset buffer
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ if {![info exists index($chan)]} {
+ driver initialize $chan
+ }
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ if {[string length $result] == 0} {
+ driver finalize $chan
+ }
+ return $result
+ }
+ }
+ }
+
+# Channel read transform that is just the identity - pass all through
+ proc idxform {cmd handle args} {
+ switch -- $cmd {
+ initialize {
+ return {initialize finalize read}
+ }
+ finalize {
+ return
+ }
+ read {
+ lassign $args buffer
+ return $buffer
+ }
+ }
+ }
+
+# Test that all EOFs pass through full xform stack. Proper data boundaries.
+# Check robustness against buffer sizes.
+test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -body {
+ set chan [chan push [chan create read driver] idxform]
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+test iortrans-4.10.1 {[5adbc350683] chan read, handle fleeting EOF} -body {
+ set chan [chan push [chan create read driver] idxform]
+ chan configure $chan -buffersize 3
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+test iortrans-4.10.2 {[5adbc350683] chan read, handle fleeting EOF} -body {
+ set chan [chan push [chan create read driver] idxform]
+ chan configure $chan -buffersize 5
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+
+rename idxform {}
+
+# Channel read transform that delays the data and always returns something
+ proc delayxform {cmd handle args} {
+ variable store
+ switch -- $cmd {
+ initialize {
+ set store($handle) {}
+ return {initialize finalize read drain}
+ }
+ finalize {
+ unset store($handle)
+ return
+ }
+ read {
+ lassign $args buffer
+ if {$store($handle) eq {}} {
+ set reply [string index $buffer 0]
+ set store($handle) [string range $buffer 1 end]
+ } else {
+ set reply $store($handle)
+ set store($handle) $buffer
+ }
+ return $reply
+ }
+ drain {
+ delayxform read $handle {}
+ }
+ }
+ }
+
+# Test that all EOFs pass through full xform stack. Proper data boundaries.
+# Check robustness against buffer sizes.
+test iortrans-4.11 {[5adbc350683] chan read, handle fleeting EOF} -body {
+ set chan [chan push [chan create read driver] delayxform]
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+test iortrans-4.11.1 {[5adbc350683] chan read, handle fleeting EOF} -body {
+ set chan [chan push [chan create read driver] delayxform]
+ chan configure $chan -buffersize 3
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+test iortrans-4.11.2 {[5adbc350683] chan read, handle fleeting EOF} -body {
+ set chan [chan push [chan create read driver] delayxform]
+ chan configure $chan -buffersize 5
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+
+ rename delayxform {}
+
+# Channel read transform that delays the data and may return {}
+ proc delay2xform {cmd handle args} {
+ variable store
+ switch -- $cmd {
+ initialize {
+ set store($handle) {}
+ return {initialize finalize read drain}
+ }
+ finalize {
+ unset store($handle)
+ return
+ }
+ read {
+ lassign $args buffer
+ set reply $store($handle)
+ set store($handle) $buffer
+ return $reply
+ }
+ drain {
+ delay2xform read $handle {}
+ }
+ }
+ }
+
+test iortrans-4.12 {[5adbc350683] chan read, handle fleeting EOF} -body {
+ set chan [chan push [chan create read driver] delay2xform]
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+
+ rename delay2xform {}
+ rename driver {}
+
+
# --- === *** ###########################
# method write (via puts)
diff --git a/tests/iogt.test b/tests/iogt.test
index 6cc0542..1ed89f7 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -871,6 +871,80 @@ test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {
close $f
} -result {xxxghi}
+
+# Driver for a base channel that emits several short "files"
+# with each terminated by a fleeting EOF
+ proc driver {cmd args} {
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) .....
+ return {initialize finalize watch read}
+ }
+ finalize {
+ if {![info exists index($chan)]} {return}
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ if {![info exists index($chan)]} {
+ driver initialize $chan
+ }
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ if {[string length $result] == 0} {
+ driver finalize $chan
+ }
+ return $result
+ }
+ }
+ }
+
+test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body {
+ set chan [chan create read [namespace which driver]]
+ identity -attach $chan
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+
+proc delay {op data} {
+ variable store
+ switch -- $op {
+ create/write - create/read -
+ delete/write - delete/read -
+ flush/write - write -
+ clear_read {;#ignore}
+ flush/read -
+ read {
+ if {![info exists store]} {set store {}}
+ set reply $store
+ set store $data
+ return $reply
+ }
+ query/maxRead {return -1}
+ }
+}
+
+test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body {
+ set chan [chan create read [namespace which driver]]
+ testchannel transform $chan -command [namespace code delay]
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+
+rename delay {}
+rename driver {}
+
# cleanup
foreach file [list dummy dummyout __echo_srv__.tcl] {
removeFile $file
diff --git a/tests/oo.test b/tests/oo.test
index 2c189ca..5fa760b 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 TclOO 1.0.1
+package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index 9a63577..5ecd209 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 TclOO 1.0.1
+package require TclOO 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
diff --git a/tests/parse.test b/tests/parse.test
index fe6026d..5d8afeb 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -303,8 +303,10 @@ test parse-6.16 {ParseTokens procedure, backslash substitution} testparser {
testparser {\n\a\x7f} 0
} {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}}
test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} {
- testparser [testbytestring "foo\0zz"] 0
-} "- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}"
+ expr {[testparser [testbytestring "foo\0zz"] 0] eq
+"- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}"
+ }
+} 1
test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} testparser {
# Test for Bug 681841
list [catch {testparser {[a]} 2} msg] $msg
@@ -916,7 +918,7 @@ test parse-15.57 {CommandComplete procedure} {
test parse-15.58 {CommandComplete procedure, memory leaks} {
info complete "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22"
} 1
-test parse-15.59 {CommandComplete procedure} {
+test parse-15.59 {CommandComplete procedure} testbytestring {
# Test for Tcl Bug 684744
info complete [testbytestring "\x00;if 1 \{"]
} 0
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 4c08b5d..a6e07a2 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -263,14 +263,14 @@ test parseOld-7.11 {backslash substitution} {
eval "list a \"b c\"\\\nd e"
} {a {b c} d e}
test parseOld-7.12 {backslash substitution} testbytestring {
- list \ua2
-} [testbytestring "\xc2\xa2"]
+ expr {[list \ua2] eq [testbytestring "\xc2\xa2"]}
+} 1
test parseOld-7.13 {backslash substitution} testbytestring {
- list \u4e21
-} [testbytestring "\xe4\xb8\xa1"]
+ expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]}
+} 1
test parseOld-7.14 {backslash substitution} testbytestring {
- list \u4e2k
-} [testbytestring "\xd3\xa2k"]
+ expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]}
+} 1
# Semi-colon.
diff --git a/tests/socket.test b/tests/socket.test
index d6cee30..eeea044 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -2249,7 +2249,7 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener
unset x
} -result {socket is not connected} -returnCodes 1
test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \
- -constraints {socket} \
+ -constraints {socket nonportable} \
-body {
set sock [socket -async localhost [randport]]
fconfigure $sock -blocking 0
diff --git a/tests/subst.test b/tests/subst.test
index 256b7f7..2115772 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -38,8 +38,8 @@ test subst-2.3 {simple strings} {
} abcdefg
test subst-2.4 {simple strings} testbytestring {
# Tcl Bug 685106
- subst [testbytestring bar\x00soom]
-} [testbytestring bar\x00soom]
+ expr {[subst [testbytestring bar\x00soom]] eq [testbytestring bar\x00soom]}
+} 1
test subst-3.1 {backslash substitutions} {
subst {\x\$x\[foo bar]\\}
diff --git a/tests/utf.test b/tests/utf.test
index 83daddf..ceb1af7 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -21,23 +21,23 @@ testConstraint testbytestring [llength [info commands testbytestring]]
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
- set x \x01
-} [testbytestring "\x01"]
+ expr {"\x01" eq [testbytestring "\x01"]}
+} 1
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
- set x "\x00"
-} [testbytestring "\xc0\x80"]
+ expr {"\x00" eq [testbytestring "\xc0\x80"]}
+} 1
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
- set x "\xe0"
-} [testbytestring "\xc3\xa0"]
+ expr {"\xe0" eq [testbytestring "\xc3\xa0"]}
+} 1
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring {
- set x "\u4e4e"
-} [testbytestring "\xe4\xb9\x8e"]
+ expr {"\u4e4e" eq [testbytestring "\xe4\xb9\x8e"]}
+} 1
test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
- format %c 0x110000
-} [testbytestring "\xef\xbf\xbd"]
+ expr {[format %c 0x110000] eq [testbytestring "\xef\xbf\xbd"]}
+} 1
test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
- format %c -1
-} [testbytestring "\xef\xbf\xbd"]
+ expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]}
+} 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
@@ -128,17 +128,17 @@ test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
} {
}
test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring {
- set x \ua2
-} [testbytestring "\xc2\xa2"]
+ expr {"\ua2" eq [testbytestring "\xc2\xa2"]}
+} 1
test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring {
- set x \u4e21
-} [testbytestring "\xe4\xb8\xa1"]
+ expr {"\u4e21" eq [testbytestring "\xe4\xb8\xa1"]}
+} 1
test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
- set x \u4e2k
-} "[testbytestring \xd3\xa2]k"
+ expr {"\u4e2k" eq "[testbytestring \xd3\xa2]k"}
+} 1
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
- set x \u4e216
-} "[testbytestring \xe4\xb8\xa1]6"
+ expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"}
+} 1
proc bsCheck {char num} {
global errNum
test utf-10.$errNum {backslash substitution} {
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index ab675d7..a808c82 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -1314,14 +1314,14 @@ test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body {
file pathtype com4
} -result "absolute"
test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body {
- file pathtype com5
-} -result "relative"
+ file pathtype com9
+} -result "absolute"
test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body {
file pathtype lpt3
} -result "absolute"
test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body {
- file pathtype lpt4
-} -result "relative"
+ file pathtype lpt9
+} -result "absolute"
test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body {
file pathtype nul
} -result "absolute"
@@ -1423,6 +1423,11 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup {
catch {file delete $tmpfile}
} -result [list 0 {} [list "tcl[pid].tmp "]]
+test winFCmd-19.9 {Windows devices path names} -constraints nt -body {
+ file normalize //./com1
+} -result //./com1
+
+
# This block of code used to occur after the "return" call, so I'm
# commenting it out and assuming that this code is still under construction.
#foreach source {tef ted tnf tnd "" nul com1} {
generated by cgit v0.12 at 2024-08-20 12:20:29 (GMT)