summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorevilotto <evilotto>2014-11-26 18:17:34 (GMT)
committerevilotto <evilotto>2014-11-26 18:17:34 (GMT)
commit5cd6e3655aa18d12fd25de99de591b2e2074049b (patch)
treeb496abc8bdbca86c65cdc20e6d21f2bc471206c2 /tests
parent6eb9ac605e8119a21ec7d047ba0da0375559d527 (diff)
parent33eb2510ff53b7fd3b32ea1c84b4ef85d00c10f8 (diff)
downloadtcl-jcr_notifier_poll.zip
tcl-jcr_notifier_poll.tar.gz
tcl-jcr_notifier_poll.tar.bz2
Merge from trunkjcr_notifier_poll
Diffstat (limited to 'tests')
-rw-r--r--tests/aaa_exit.test54
-rw-r--r--tests/append.test17
-rw-r--r--tests/appendComp.test21
-rw-r--r--tests/compile.test82
-rw-r--r--tests/coroutine.test14
-rw-r--r--tests/error.test6
-rw-r--r--tests/fileSystem.test3
-rw-r--r--tests/interp.test4
-rw-r--r--tests/io.test245
-rw-r--r--tests/ioTrans.test173
-rw-r--r--tests/iogt.test74
-rw-r--r--tests/lreplace.test14
-rw-r--r--tests/oo.test12
-rw-r--r--tests/ooNext2.test2
-rw-r--r--tests/parse.test8
-rw-r--r--tests/parseOld.test12
-rw-r--r--tests/regexpComp.test5
-rw-r--r--tests/socket.test24
-rw-r--r--tests/subst.test4
-rw-r--r--tests/upvar.test3
-rw-r--r--tests/utf.test46
-rw-r--r--tests/var.test18
-rw-r--r--tests/winFCmd.test13
23 files changed, 807 insertions, 47 deletions
diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test
new file mode 100644
index 0000000..3ba5167
--- /dev/null
+++ b/tests/aaa_exit.test
@@ -0,0 +1,54 @@
+# Commands covered: exit, emphasis on finalization hangs
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1991-1993 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.
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+}
+
+test exit-1.1 {normal, quick exit} {
+ set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r]
+ set aft [after 1000 {set done "Quick exit hangs !!!"}]
+ fileevent $f readable {after cancel $aft;set done OK}
+ vwait done
+ if {$done != "OK"} {
+ fconfigure $f -blocking 0
+ close $f
+ } else {
+ if {[catch {close $f} err]} {
+ set done "Quick exit misbehaves: $err"
+ }
+ }
+ set done
+} OK
+
+test exit-1.2 {full-finalized exit} {
+ set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r]
+ set aft [after 1000 {set done "Full-finalized exit hangs !!!"}]
+ fileevent $f readable {after cancel $aft;set done OK}
+ vwait done
+ if {$done != "OK"} {
+ fconfigure $f -blocking 0
+ close $f
+ } else {
+ if {[catch {close $f} err]} {
+ set done "Full-finalized exit misbehaves: $err"
+ }
+ }
+ set done
+} OK
+
+
+# cleanup
+::tcltest::cleanupTests
+return
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 2852bf2..22ebc7d 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -658,12 +658,15 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup
# does not check the format of disassembled bytecode though; that's liable to
# change without warning.
+set disassemblables [linsert [join {
+ lambda method objmethod proc script
+} ", "] end-1 or]
test compile-18.1 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble
} -match glob -result {wrong # args: should be "*"}
test compile-18.2 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble ?
-} -match glob -result {bad type "?": must be *}
+} -result "bad type \"?\": must be $disassemblables"
test compile-18.3 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::disassemble lambda
} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
@@ -737,6 +740,83 @@ test compile-18.19 {disassembler - basics} -setup {
} -cleanup {
foo destroy
} -match glob -result *
+# There never was a compile-18.20.
+# The keys of the dictionary produced by [getbytecode] are defined.
+set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth}
+test compile-18.21 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode
+} -match glob -result {wrong # args: should be "*"}
+test compile-18.22 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode ?
+} -result "bad type \"?\": must be $disassemblables"
+test compile-18.23 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode lambda
+} -match glob -result {wrong # args: should be "* lambda lambdaTerm"}
+test compile-18.24 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode lambda \{
+} -result "can't interpret \"\{\" as a lambda expression"
+test compile-18.25 {disassembler - basics} -body {
+ dict keys [tcl::unsupported::getbytecode lambda {{} {}}]
+} -result $bytecodekeys
+test compile-18.26 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode proc
+} -match glob -result {wrong # args: should be "* proc procName"}
+test compile-18.27 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode proc nosuchproc
+} -result {"nosuchproc" isn't a procedure}
+test compile-18.28 {disassembler - basics} -setup {
+ proc chewonthis {} {}
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename chewonthis {}
+} -result $bytecodekeys
+test compile-18.29 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode script
+} -match glob -result {wrong # args: should be "* script script"}
+test compile-18.30 {disassembler - basics} -body {
+ dict keys [tcl::unsupported::getbytecode script {}]
+} -result $bytecodekeys
+test compile-18.31 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode method
+} -match glob -result {wrong # args: should be "* method className methodName"}
+test compile-18.32 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode method nosuchclass foo
+} -result {nosuchclass does not refer to an object}
+test compile-18.33 {disassembler - basics} -returnCodes error -setup {
+ oo::object create justanobject
+} -body {
+ tcl::unsupported::getbytecode method justanobject foo
+} -cleanup {
+ justanobject destroy
+} -result {"justanobject" is not a class}
+test compile-18.34 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode method oo::object nosuchmethod
+} -result {unknown method "nosuchmethod"}
+test compile-18.35 {disassembler - basics} -setup {
+ oo::class create foo {method bar {} {}}
+} -body {
+ dict keys [tcl::unsupported::getbytecode method foo bar]
+} -cleanup {
+ foo destroy
+} -result $bytecodekeys
+test compile-18.36 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode objmethod
+} -match glob -result {wrong # args: should be "* objmethod objectName methodName"}
+test compile-18.37 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode objmethod nosuchobject foo
+} -result {nosuchobject does not refer to an object}
+test compile-18.38 {disassembler - basics} -returnCodes error -body {
+ tcl::unsupported::getbytecode objmethod oo::object nosuchmethod
+} -result {unknown method "nosuchmethod"}
+test compile-18.39 {disassembler - basics} -setup {
+ oo::object create foo
+ oo::objdefine foo {method bar {} {}}
+} -body {
+ dict keys [tcl::unsupported::getbytecode objmethod foo bar]
+} -cleanup {
+ foo destroy
+} -result $bytecodekeys
test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
# This will panic in a --enable-symbols=compile build, unless bug is fixed.
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 05b58c9..205da67 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -726,6 +726,20 @@ test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup {
catch {namespace delete ::cotest}
catch {rename cotest ""}
} -result {yieldto called in deleted namespace}
+test coroutine-7.12 {coro floor above street level #3008307} -body {
+ proc c {} {
+ yield
+ }
+ proc cc {} {
+ coroutine C c
+ }
+ proc boom {} {
+ cc ; # coro created at level 2
+ C ; # and called at level 1
+ }
+ boom ; # does not crash: the coro floor is a good insulator
+ list
+} -result {}
# cleanup
diff --git a/tests/error.test b/tests/error.test
index 0de644c..af07ed7 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -1184,6 +1184,12 @@ test error-21.8 {memory leaks in try: Bug 2910044} memory {
}
} 0
+test error-21.9 {Bug cee90e4e88} {
+ # Just don't panic.
+ apply {{} {try {} on ok {} - on return {} {}}}
+} {}
+
+
# negative case try tests - bad "trap" handler
# what is the effect if we attempt to trap an errorcode that is not a list?
# nested try
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 639691a..b09d55a 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -1484,6 +1484,39 @@ test io-12.6 {ReadChars: too many chars read} {
}
close $c
} {}
+test io-12.7 {ReadChars: too many chars read [bc5b790099]} {
+ proc driver {cmd args} {
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat \uBEEF 10]....\uBEEF]
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
+ }
+ set c [chan create read [namespace which driver]]
+ chan configure $c -encoding utf-8
+ while {![eof $c]} {
+ read $c 7
+ }
+ close $c
+} {}
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
@@ -4292,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.
@@ -7675,6 +7812,94 @@ test io-53.14 {TclCopyChannel: write error reporting} -setup {
removeFile in
rename driver {}
} -result {error writing "*": *} -returnCodes error -match glob
+test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
+ proc driver {cmd args} {
+ variable buffer
+ variable index
+ variable blocked
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat a 100]]
+ set blocked($chan) 1
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan) blocked($chan)
+ return
+ }
+ watch {}
+ read {
+ if {$blocked($chan)} {
+ set blocked($chan) [expr {!$blocked($chan)}]
+ return -code error EAGAIN
+ }
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
+ }
+ set c [chan create read [namespace which driver]]
+ chan configure $c -encoding utf-8
+ set out [makeFile {} out]
+ set outChan [open $out w]
+ chan configure $outChan -encoding utf-8
+} -body {
+ chan copy $c $outChan
+} -cleanup {
+ close $outChan
+ close $c
+ removeFile out
+} -result 100
+test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup {
+ proc driver {cmd args} {
+ variable buffer
+ variable index
+ variable blocked
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ set index($chan) 0
+ set buffer($chan) [encoding convertto utf-8 \
+ [string repeat a 100]]
+ set blocked($chan) 1
+ return {initialize finalize watch read}
+ }
+ finalize {
+ unset index($chan) buffer($chan) blocked($chan)
+ return
+ }
+ watch {}
+ read {
+ if {$blocked($chan)} {
+ set blocked($chan) [expr {!$blocked($chan)}]
+ return -code error EAGAIN
+ }
+ set n [lindex $args 1]
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ return $result
+ }
+ }
+ }
+ set c [chan create read [namespace which driver]]
+ chan configure $c -encoding utf-8 -translation lf
+ set out [makeFile {} out]
+ set outChan [open $out w]
+ chan configure $outChan -encoding utf-8 -translation lf
+} -body {
+ chan copy $c $outChan
+} -cleanup {
+ close $outChan
+ close $c
+ removeFile out
+} -result 100
test io-54.1 {Recursive channel events} {socket fileevent} {
# This test checks to see if file events are delivered during recursive
@@ -8240,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/lreplace.test b/tests/lreplace.test
index 5f675bc..b976788 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -15,7 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
-
+
test lreplace-1.1 {lreplace command} {
lreplace {1 2 3 4 5} 0 0 a
} {a 2 3 4 5}
@@ -130,7 +130,19 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} {
p
} "a b c"
+test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} {
+ lreplace {} 1 1
+} {}
+# Note that this test will fail in 8.5
+test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} {
+ lreplace { } 1 1
+} {}
+
# cleanup
catch {unset foo}
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/oo.test b/tests/oo.test
index 8c515da..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::*
@@ -271,6 +271,16 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
} -cleanup {
rename test-oo-1.18 {}
} -result 0
+test oo-1.18.2 {Bug 21c144f0f5} -setup {
+ interp create slave
+} -body {
+ slave eval {
+ oo::define [oo::class create foo] superclass oo::class
+ oo::class destroy
+ }
+} -cleanup {
+ interp delete slave
+}
test oo-1.19 {basic test of OO functionality: teardown order} -body {
oo::object create o
namespace delete [info object namespace o]
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..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/regexpComp.test b/tests/regexpComp.test
index 7be1195..01ef06d 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -526,6 +526,11 @@ test regexpComp-9.6 {-all option to regsub} {
list [regsub -all ^ xxx 123 foo] $foo
}
} {1 123xxx}
+test regexpComp-9.7 {Bug 84af1192f5: -all option to regsub} {
+ evalInProc {
+ regsub -all {\(.*} 123(qwe) ""
+ }
+} 123
test regexpComp-10.1 {expanded syntax in regsub} {
evalInProc {
diff --git a/tests/socket.test b/tests/socket.test
index c50730c..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
@@ -2321,6 +2321,28 @@ test socket-14.15 {blocking read on async socket should not trigger event handle
set x
} -result ok
+# v4 and v6 is required to prevent that the async connect does not terminate
+# before the fconfigure command. There is always an additional ip to try.
+test socket-14.16 {empty -peername while [socket -async] connecting} \
+ -constraints {socket localhost_v4 localhost_v6} \
+ -body {
+ set client [socket -async localhost [randport]]
+ fconfigure $client -peername
+ } -cleanup {
+ catch {close $client}
+ } -result {}
+
+# v4 and v6 is required to prevent that the async connect does not terminate
+# before the fconfigure command. There is always an additional ip to try.
+test socket-14.17 {empty -sockname while [socket -async] connecting} \
+ -constraints {socket localhost_v4 localhost_v6} \
+ -body {
+ set client [socket -async localhost [randport]]
+ fconfigure $client -sockname
+ } -cleanup {
+ catch {close $client}
+ } -result {}
+
set num 0
set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}}
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/upvar.test b/tests/upvar.test
index e93f58a..5ea870d 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -339,7 +339,7 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v
unset ::test_ns_1::a
}
MakeLink 1
-} -result {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}
+} -result {bad variable name "a": can't create namespace variable that refers to procedure variable}
test upvar-8.10 {upvar will create element alias for new array element} -setup {
catch {unset upvarArray}
} -body {
@@ -578,7 +578,6 @@ test upvar-NS-3.3 {CompileWord OBOE} -setup {
} -cleanup {
rename linenumber {}
} -result 1
-
# cleanup
::tcltest::cleanupTests
diff --git a/tests/utf.test b/tests/utf.test
index 2fcac49..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} {
@@ -287,9 +287,11 @@ test utf-18.5 {Tcl_UniCharToTitle, no delta} {
string totitle !
} !
-test utf-19.1 {TclUniCharLen} {
+test utf-19.1 {TclUniCharLen} -body {
list [regexp \\d abc456def foo] $foo
-} {1 4}
+} -cleanup {
+ unset -nocomplain foo
+} -result {1 4}
test utf-20.1 {TclUniCharNcmp} {
} {}
diff --git a/tests/var.test b/tests/var.test
index 208b361..7ff394e 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -289,7 +289,7 @@ test var-3.11 {MakeUpvar, my var looks like array elem} -setup {
} -returnCodes error -body {
set aaaaa 789789
upvar #0 aaaaa foo(bar)
-} -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element}
+} -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element}
test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname {
catch {unset a}
@@ -865,6 +865,22 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup {
}}
array size x
} -result 0
+test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup {
+ variable foo
+ variable lambda
+ unset -nocomplain lambda foo
+ array set foo {}
+ lappend lambda {}
+ lappend lambda [list array set [namespace which -variable foo] {a 1}]
+} -body {
+ after 0 [list apply $lambda]
+ vwait [namespace which -variable foo]
+} -cleanup {
+ unset -nocomplain lambda foo
+} -result {}
+test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
+ apply {{} {set name foo(bar); array set $name {a 1}}}
+} -returnCodes error -match glob -result *
test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
proc linenumber {} {dict get [info frame -1] line}
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} {