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/compile.test12
-rw-r--r--tests/fileSystem.test3
-rw-r--r--tests/interp.test4
-rw-r--r--tests/io.test124
-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.test11
-rw-r--r--tests/parseExpr.test9
-rw-r--r--tests/parseOld.test12
-rw-r--r--tests/socket.test20
-rw-r--r--tests/stringComp.test8
-rw-r--r--tests/subst.test4
-rw-r--r--tests/utf.test40
-rw-r--r--tests/winFCmd.test13
18 files changed, 507 insertions, 42 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/compile.test b/tests/compile.test
index 22ebc7d..d4a31d4 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -455,14 +455,22 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
-# Special test for compiling tokens from a copy of the source string. [Bug
-# 599788]
+# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
test compile-14.1 {testing errors in element name; segfault?} {} {
catch {set a([error])} msg1
catch {set bubba([join $abba $jubba]) $vol} msg2
list $msg1 $msg2
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
+test compile-14.2 {testing element name "$"} -body {
+ unset -nocomplain a
+ set a() 1
+ set a(1) 2
+ set a($) 3
+ list [set a()] [set a(1)] [set a($)] [unset a() a(1); lindex [array names a] 0]
+} -cleanup {unset a} -result [list 1 2 3 {$}]
+
+
# Tests compile-15.* cover Tcl Bug 633204
test compile-15.1 {proper TCL_RETURN code from [return]} {
apply {{} {catch return}}
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 d9a5167..b09d55a 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -4325,6 +4325,110 @@ test io-33.10 {Tcl_Gets, exercising double buffering} {
close $f
set y
} 300
+test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup {
+ 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 {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ if {$n > 3} {set n 3}
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
+ }
+} -body {
+ set c [chan create read [namespace which driver]]
+ chan configure $c -translation binary -blocking 0
+ list [gets $c] [gets $c] [gets $c] [gets $c]
+} -cleanup {
+ close $c
+ rename driver {}
+} -result {{} {} {} .......}
+test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup {
+ 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 {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ if {$n > 3} {set n 3}
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
+ }
+} -body {
+ set c [chan create read [namespace which driver]]
+ chan configure $c -blocking 0
+ list [gets $c] [gets $c] [gets $c] [gets $c]
+} -cleanup {
+ close $c
+ rename driver {}
+} -result {{} {} {} .......}
+test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup {
+ proc driver {cmd args} {
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [string repeat \
+ [string repeat . 64]\n[string repeat . 25] 2]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ if {$n > 65} {set n 65}
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
+ }
+} -body {
+ set c [chan create read [namespace which driver]]
+ chan configure $c -blocking 0
+ list [gets $c] [gets $c] [gets $c] [gets $c] [gets $c]
+} -cleanup {
+ close $c
+ rename driver {}
+} -result [list [string repeat . 64] {} [string repeat . 89] \
+ [string repeat . 25] {}]
# Test Tcl_Seek and Tcl_Tell.
@@ -8361,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..d73c725 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
@@ -661,6 +663,9 @@ test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array refer
test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} testparser {
testparser {$x(a$y(b$z))} 0
} {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}}
+test parse-12.26 {Tcl_ParseVarName [d2ffcca163] non-ascii} testparser {
+ testparser "$\u0433" -1
+} "- {$\u0433} 1 word {$\u0433} 2 text {$} 0 text \u0433 0 {}"
test parse-13.1 {Tcl_ParseVar procedure} testparsevar {
set abc 24
@@ -916,7 +921,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/parseExpr.test b/tests/parseExpr.test
index 5c7986a..ef05454 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -1064,6 +1064,15 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body {
dict get $o -errorcode
} -result {TCL PARSE EXPR BADNUMBER BINARY}
+test parseExpr-22.19 {Bug d2ffcca163} -constraints testexprparser -body {
+ testexprparser \u0433 -1
+} -returnCodes error -match glob -result {*invalid character*}
+test parseExpr-22.20 {Bug d2ffcca163} -constraints testexprparser -body {
+ testexprparser \u043f -1
+} -returnCodes error -match glob -result {*invalid character*}
+test parseExpr-22.21 {Bug d2ffcca163} -constraints testexprparser -body {
+ testexprparser in\u0433(0) -1
+} -returnCodes error -match glob -result {missing operand*}
# cleanup
cleanupTests
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 4c08b5d..a6e07a2b 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..4f90e51 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
@@ -2343,6 +2343,24 @@ test socket-14.17 {empty -sockname while [socket -async] connecting} \
catch {close $client}
} -result {}
+# test for bug c6ed4acfd8: running async socket connect with other connect
+# established will block tcl as it goes in an infinite loop in vwait
+test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} \
+ -constraints {socket} \
+ -body {
+ proc accept {channel address port} {}
+ set port [randport]
+ set ssock [socket -server accept $port]
+ set csock1 [socket -async localhost [randport]]
+ set csock2 [socket localhost $port]
+ after 1000 {set done ok}
+ vwait done
+} -cleanup {
+ catch {close $ssock}
+ catch {close $csock1}
+ catch {close $csock2}
+ } -result {}
+
set num 0
set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}}
diff --git a/tests/stringComp.test b/tests/stringComp.test
index f9f6bda..a66525e 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -720,6 +720,14 @@ test stringComp-14.2 {Bug 82e7f67325} memory {
}} {a b}
}
} {0}
+test stringComp-14.3 {Bug 0dca3bfa8f} {
+ apply {arg {
+ set argCopy $arg
+ set arg [string replace $arg 1 2 aa]
+ # Crashes in comparison before fix
+ expr {$arg ne $argCopy}
+ }} abcde
+} 1
## string tolower
## not yet bc
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-11-18 04:55:22 (GMT)