summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2015-07-17 21:22:22 (GMT)
committerdgp <dgp@users.sourceforge.net>2015-07-17 21:22:22 (GMT)
commit5234a59846f046760830b06488e2d214d0b2cf04 (patch)
treeeb303b04e47fe05468dc5620171a0ee2c8453095 /tests
parent2fc3c8d6596a5d180b7f2c13451e8ec26144cb2b (diff)
parentad86656b196a9b34f2df43327c816d8099d7f3c8 (diff)
downloadtcl-5234a59846f046760830b06488e2d214d0b2cf04.zip
tcl-5234a59846f046760830b06488e2d214d0b2cf04.tar.gz
tcl-5234a59846f046760830b06488e2d214d0b2cf04.tar.bz2
merge trunk
Diffstat (limited to 'tests')
-rw-r--r--tests/aaa_exit.test54
-rw-r--r--tests/all.tcl3
-rw-r--r--tests/append.test17
-rw-r--r--tests/appendComp.test21
-rw-r--r--tests/chanio.test22
-rw-r--r--tests/clock.test21
-rw-r--r--tests/cmdAH.test13
-rw-r--r--tests/compile.test188
-rw-r--r--tests/coroutine.test109
-rw-r--r--tests/dict.test131
-rw-r--r--tests/env.test25
-rw-r--r--tests/error.test6
-rw-r--r--tests/exec.test6
-rw-r--r--tests/execute.test23
-rw-r--r--tests/expr.test4
-rw-r--r--tests/fCmd.test96
-rw-r--r--tests/fileSystem.test3
-rw-r--r--tests/for.test242
-rw-r--r--tests/http.test40
-rw-r--r--tests/http11.test33
-rw-r--r--tests/httpd11.tcl15
-rw-r--r--tests/interp.test4
-rw-r--r--tests/io.test876
-rw-r--r--tests/ioCmd.test121
-rw-r--r--tests/ioTrans.test230
-rw-r--r--tests/iogt.test183
-rw-r--r--tests/load.test6
-rw-r--r--tests/lreplace.test58
-rw-r--r--tests/msgcat.test417
-rw-r--r--tests/namespace.test15
-rw-r--r--tests/nre.test21
-rw-r--r--tests/obj.test4
-rw-r--r--tests/oo.test121
-rw-r--r--tests/ooNext2.test279
-rw-r--r--tests/parse.test36
-rw-r--r--tests/parseExpr.test14
-rw-r--r--tests/parseOld.test19
-rw-r--r--tests/regexp.test16
-rw-r--r--tests/regexpComp.test21
-rw-r--r--tests/registry.test4
-rw-r--r--tests/scan.test17
-rw-r--r--tests/set-old.test5
-rw-r--r--tests/socket.test664
-rw-r--r--tests/source.test10
-rw-r--r--tests/string.test47
-rw-r--r--tests/stringComp.test80
-rw-r--r--tests/stringObj.test19
-rw-r--r--tests/subst.test20
-rw-r--r--tests/switch.test8
-rw-r--r--tests/tailcall.test30
-rwxr-xr-xtests/tcltest.test36
-rw-r--r--tests/thread.test6
-rw-r--r--tests/unixFCmd.test2
-rw-r--r--tests/upvar.test3
-rw-r--r--tests/utf.test150
-rw-r--r--tests/util.test5
-rw-r--r--tests/var.test18
-rw-r--r--tests/winFCmd.test159
-rw-r--r--tests/winFile.test18
-rw-r--r--tests/winPipe.test8
-rw-r--r--tests/zlib.test13
61 files changed, 4246 insertions, 589 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/all.tcl b/tests/all.tcl
index 05d3024..0a6f57f 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -15,5 +15,8 @@ package require Tcl 8.5
package require tcltest 2.2
namespace import tcltest::*
configure {*}$argv -testdir [file dir [info script]]
+if {[singleProcess]} {
+ interp debug {} -frame 1
+}
runAllTests
proc exit args {}
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/chanio.test b/tests/chanio.test
index 999d0bb..2738fc6 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -13,10 +13,16 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[catch {package require tcltest 2}]} {
- chan puts stderr "Skipping tests in [info script]. tcltest 2 required."
- return
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
+testConstraint testbytestring [llength [info commands testbytestring]]
+
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
@@ -44,7 +50,7 @@ namespace eval ::tcl::test::io {
# You need a *very* special environment to do some tests. In particular,
# many file systems do not support large-files...
- testConstraint largefileSupport 0
+ testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2 if "umask" cannot be run, the
# tests will be skipped.
@@ -4520,10 +4526,10 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup {
chan puts -nonewline $f abcdef
lappend l [chan tell $f]
chan close $f
- lappend l [file size $f]
+ lappend l [file size $path(test3)]
# truncate...
chan close [open $path(test3) w]
- lappend l [file size $f]
+ lappend l [file size $path(test3)]
} -result {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
@@ -7426,11 +7432,11 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} {
string equal $result [testmainthread]
} {1}
-test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} {
+test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
chan puts $out {
- chan puts [encoding convertfrom identity \xe2]
+ chan puts [testbytestring \xe2]
exit 1
}
proc readit {pipe} {
diff --git a/tests/clock.test b/tests/clock.test
index 0202fc7..2abeab9 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -273,7 +273,7 @@ test clock-1.4 "clock format - bad flag" {*}{
list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
}
-match glob
- -result {1 {bad switch "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badSwitch -oops}}
+ -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}
}
test clock-1.5 "clock format - bad timezone" {
@@ -35450,7 +35450,7 @@ test clock-33.2 {clock clicks tests} {
} {1}
test clock-33.3 {clock clicks tests} {
list [catch {clock clicks foo} msg] $msg
-} {1 {bad switch "foo": must be -milliseconds or -microseconds}}
+} {1 {bad option "foo": must be -milliseconds or -microseconds}}
test clock-33.4 {clock clicks tests} {
expr [clock clicks -milliseconds]+1
concat {}
@@ -35485,10 +35485,10 @@ test clock-33.5a {clock tests, millisecond timing test} {
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks ? } msg] $msg
-} {1 {bad switch "?": must be -milliseconds or -microseconds}}
+} {1 {bad option "?": must be -milliseconds or -microseconds}}
test clock-33.7 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks - } msg] $msg
-} {1 {ambiguous switch "-": must be -milliseconds or -microseconds}}
+} {1 {ambiguous option "-": must be -milliseconds or -microseconds}}
test clock-33.8 {clock clicks test, microsecond timing test} {
# This test can fail on a system that is so heavily loaded that
@@ -35607,7 +35607,7 @@ test clock-34.8 {clock scan tests} {
} {Oct 23,1992 15:00 GMT}
test clock-34.9 {clock scan tests} {
list [catch {clock scan "Jan 12" -bad arg} msg] $msg
-} {1 {bad switch "-bad", must be -base, -format, -gmt, -locale or -timezone}}
+} {1 {bad option "-bad", must be -base, -format, -gmt, -locale or -timezone}}
# The following two two tests test the two year date policy
test clock-34.10 {clock scan tests} {
set time [clock scan "1/1/71" -gmt true]
@@ -36907,7 +36907,7 @@ test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{
}
-match glob
-returnCodes error
- -result {bad switch "-foo"*}
+ -result {bad option "-foo"*}
}
test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{
@@ -36927,6 +36927,15 @@ test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} {
clock format [clock seconds] -format %%r
} %r
+test clock-67.2 {Bug d19a30db57} -body {
+ # error, not segfault
+ tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
+} -returnCodes error -match glob -result *
+test clock-67.3 {Bug d19a30db57} -body {
+ # error, not segfault
+ tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222
+} -returnCodes error -match glob -result *
+
# cleanup
namespace delete ::testClock
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 39e9ece..64cfeba 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -141,6 +141,9 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup {
} -cleanup {
cd $dir
} -result {/}
+test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -returnCodes error -body {
+ cd .\0
+} -result "couldn't change working directory to \".\0\": no such file or directory"
test cmdAH-2.7 {Tcl_ConcatObjCmd} {
concat
} {}
@@ -826,13 +829,13 @@ test cmdAH-16.1 {Tcl_FileObjCmd: readable} {
}
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
-constraints testchmod
- -setup {testchmod 0444 $gorpfile}
+ -setup {testchmod 0o444 $gorpfile}
-body {file readable $gorpfile}
-result 1
}
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {
-constraints {unix notRoot testchmod}
- -setup {testchmod 0333 $gorpfile}
+ -setup {testchmod 0o333 $gorpfile}
-body {file readable $gorpfile}
-result 0
}
@@ -845,13 +848,13 @@ test cmdAH-17.1 {Tcl_FileObjCmd: writable} {
}
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {
-constraints {notRoot testchmod}
- -setup {testchmod 0555 $gorpfile}
+ -setup {testchmod 0o555 $gorpfile}
-body {file writable $gorpfile}
-result 0
}
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
-constraints testchmod
- -setup {testchmod 0222 $gorpfile}
+ -setup {testchmod 0o222 $gorpfile}
-body {file writable $gorpfile}
-result 1
}
@@ -870,7 +873,7 @@ test cmdAH-18.2 {Tcl_FileObjCmd: executable} {notRoot} {
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
# Only on unix will setting the execute bit on a regular file cause that
# file to be executable.
- testchmod 0775 $gorpfile
+ testchmod 0o775 $gorpfile
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
diff --git a/tests/compile.test b/tests/compile.test
index 51db0a2..d4a31d4 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -167,6 +167,36 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*}
-cleanup {namespace delete catchtest}
}
+test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{
+ -setup {
+ namespace eval catchtest {
+ variable options1 {}
+ }
+ trace add variable catchtest::options1 write catchtest::failtrace
+ proc catchtest::failtrace {n1 n2 op} {
+ return -code error "trace on $n1 fails by request"
+ }
+ }
+ -body {
+ proc catchtest::x {} {
+ variable options1
+ set count 0
+ for {set i 0} {$i < 10} {incr i} {
+ set status2 [catch {
+ set status1 [catch {
+ return -code error -level 0 "original failure"
+ } result1 options1]
+ } result2 options2]
+ incr count
+ }
+ list $count $result2
+ }
+ catchtest::x
+ }
+ -result {10 {can't set "options1": trace on options1 fails by request}}
+ -cleanup {namespace delete catchtest}
+}
+
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
set i 0
set j 0
@@ -425,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}}
@@ -628,12 +666,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"}
@@ -707,12 +748,153 @@ 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.
apply {{} {list [if 1]}}
} -returnCodes error -match glob -result *
+test compile-20.1 {ensure there are no infinite loops in optimizing} {
+ tcl::unsupported::disassemble script {
+ while 1 {
+ return -code continue -level 0
+ }
+ }
+ return
+} {}
+test compile-20.2 {ensure there are no infinite loops in optimizing} {
+ tcl::unsupported::disassemble script {
+ while 1 {
+ while 1 {
+ return -code break -level 0
+ }
+ }
+ }
+ return
+} {}
+
+test compile-21.1 {stack balance management} {
+ apply {{} {
+ set result {}
+ while 1 {
+ lappend result a
+ lappend result [list b [break]]
+ lappend result c
+ }
+ return $result
+ }}
+} a
+test compile-21.2 {stack balance management} {
+ apply {{} {
+ set result {}
+ while {[incr i] <= 10} {
+ lappend result $i
+ lappend result [list b [continue] c]
+ lappend result c
+ }
+ return $result
+ }}
+} {1 2 3 4 5 6 7 8 9 10}
+test compile-21.3 {stack balance management} {
+ apply {args {
+ set result {}
+ while 1 {
+ lappend result a
+ lappend result [concat {*}$args [break]]
+ lappend result c
+ }
+ return $result
+ }} P Q R S T
+} a
+test compile-21.4 {stack balance management} {
+ apply {args {
+ set result {}
+ while {[incr i] <= 10} {
+ lappend result $i
+ lappend result [concat {*}$args [continue] c]
+ lappend result c
+ }
+ return $result
+ }} P Q R S T
+} {1 2 3 4 5 6 7 8 9 10}
+
# TODO sometime - check that bytecode from tbcload is *not* disassembled.
# cleanup
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 03c63ad..205da67 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -1,4 +1,4 @@
-# Commands covered: coroutine, yield, [info coroutine]
+# Commands covered: coroutine, yield, yieldto, [info coroutine]
#
# This file contains a collection of tests for experimental commands that are
# found in ::tcl::unsupported. The tests will migrate to normal test files
@@ -342,6 +342,9 @@ test coroutine-3.6 {info frame, bug #2910094} -setup {
rename stack {}
rename a {}
} -result {}
+test coroutine-3.7 {bug 0b874c344d} {
+ dict get [coroutine X coroutine Y info frame 0] cmd
+} {coroutine X coroutine Y info frame 0}
test coroutine-4.1 {bug #2093188} -setup {
proc foo {} {
@@ -609,7 +612,6 @@ test coroutine-7.3 {yielding between coroutines} -body {
} -cleanup {
catch {rename juggler ""}
} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
-
test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
proc foo {a b} {catch yield; return 1}
} -cleanup {
@@ -617,7 +619,6 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup {
} -body {
coroutine demo lsort -command foo {a b}
} -result {b a}
-
test coroutine-7.5 {return codes} {
set result {}
foreach code {0 1 2 3 4 5} {
@@ -625,14 +626,12 @@ test coroutine-7.5 {return codes} {
}
set result
} {0 1 2 3 4 5}
-
test coroutine-7.6 {Early yield crashes} {
proc foo args {}
trace add execution foo enter {catch yield}
coroutine demo foo
rename foo {}
} {}
-
test coroutine-7.7 {Bug 2486550} -setup {
interp hide {} yield
} -body {
@@ -641,6 +640,106 @@ test coroutine-7.7 {Bug 2486550} -setup {
demo
interp expose {} yield
} -result ok
+test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
+ namespace eval cotest {}
+ set ::result ""
+} -body {
+ proc cotest::body {} {
+ lappend ::result a
+ yield OUT
+ lappend ::result b
+ yieldto ::return -level 0 123
+ lappend ::result c
+ return
+ }
+ lappend ::result [coroutine cotest cotest::body]
+ namespace delete cotest
+ namespace eval cotest {}
+ lappend ::result [cotest]
+ cotest
+ return $result
+} -returnCodes error -cleanup {
+ catch {namespace delete ::cotest}
+ catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup {
+ namespace eval cotest {}
+ set ::result ""
+} -body {
+ proc cotest::body {} {
+ set y ::yieldto
+ lappend ::result a
+ yield OUT
+ lappend ::result b
+ $y ::return -level 0 123
+ lappend ::result c
+ return
+ }
+ lappend ::result [coroutine cotest cotest::body]
+ namespace delete cotest
+ namespace eval cotest {}
+ lappend ::result [cotest]
+ cotest
+ return $result
+} -returnCodes error -cleanup {
+ catch {namespace delete ::cotest}
+ catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup {
+ namespace eval cotest {}
+ set ::result ""
+} -body {
+ proc cotest::body {} {
+ lappend ::result a
+ yield OUT
+ lappend ::result b
+ yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123
+ lappend ::result c
+ return
+ }
+ lappend ::result [coroutine cotest cotest::body]
+ lappend ::result [cotest]
+ cotest
+ return $result
+} -returnCodes error -cleanup {
+ catch {namespace delete ::cotest}
+ catch {rename cotest ""}
+} -result {yieldto called in deleted namespace}
+test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup {
+ namespace eval cotest {}
+ set ::result ""
+} -body {
+ proc cotest::body {} {
+ set y ::yieldto
+ lappend ::result a
+ yield OUT
+ lappend ::result b
+ $y ::return -level 0 -cotest [namespace delete ::cotest] 123
+ lappend ::result c
+ return
+ }
+ lappend ::result [coroutine cotest cotest::body]
+ lappend ::result [cotest]
+ cotest
+ return $result
+} -returnCodes error -cleanup {
+ 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/dict.test b/tests/dict.test
index a583de8..d5406d0 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -167,6 +167,51 @@ test dict-4.8 {dict replace command} -returnCodes error -body {
} -result {missing value to go with key}
test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b}
test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c}
+test dict-4.11 {dict replace command: canonicality is forced} {
+ dict replace { a b c d }
+} {a b c d}
+test dict-4.12 {dict replace command: canonicality is forced} {
+ dict replace {a b c d a e}
+} {a e c d}
+test dict-4.13 {dict replace command: type check is mandatory} -body {
+ dict replace { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-4.13a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b c d e }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY}
+test dict-4.14 {dict replace command: type check is mandatory} -body {
+ dict replace { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
+test dict-4.14a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b {}c d }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY JUNK}
+test dict-4.15 {dict replace command: type check is mandatory} -body {
+ dict replace { a b ""c d }
+} -returnCodes error -result {dict element in quotes followed by "c" instead of space}
+test dict-4.15a {dict replace command: type check is mandatory} {
+ catch {dict replace { a b ""c d }} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY JUNK}
+test dict-4.16 {dict replace command: type check is mandatory} -body {
+ dict replace " a b \"c d "
+} -returnCodes error -result {unmatched open quote in dict}
+test dict-4.16a {dict replace command: type check is mandatory} {
+ catch {dict replace " a b \"c d "} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY QUOTE}
+test dict-4.17 {dict replace command: type check is mandatory} -body {
+ dict replace " a b \{c d "
+} -returnCodes error -result {unmatched open brace in dict}
+test dict-4.17a {dict replace command: type check is mandatory} {
+ catch {dict replace " a b \{c d "} -> opt
+ dict get $opt -errorcode
+} {TCL VALUE DICTIONARY BRACE}
+test dict-4.18 {dict replace command: canonicality forcing doesn't leak} {
+ set example { a b c d }
+ list $example [dict replace $example]
+} {{ a b c d } {a b c d}}
test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d}
test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b}
@@ -179,6 +224,25 @@ test dict-5.6 {dict remove command} {dict remove {a b} c} {a b}
test dict-5.7 {dict remove command} -returnCodes error -body {
dict remove
} -result {wrong # args: should be "dict remove dictionary ?key ...?"}
+test dict-5.8 {dict remove command: canonicality is forced} {
+ dict remove { a b c d }
+} {a b c d}
+test dict-5.9 {dict remove command: canonicality is forced} {
+ dict remove {a b c d a e}
+} {a e c d}
+test dict-5.10 {dict remove command: canonicality forced by update} {
+ dict remove { a b c d } c
+} {a b}
+test dict-5.11 {dict remove command: type check is mandatory} -body {
+ dict remove { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-5.12 {dict remove command: type check is mandatory} -body {
+ dict remove { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
+test dict-5.13 {dict remove command: canonicality forcing doesn't leak} {
+ set example { a b c d }
+ list $example [dict remove $example]
+} {{ a b c d } {a b c d}}
test dict-6.1 {dict keys command} {dict keys {a b}} a
test dict-6.2 {dict keys command} {dict keys {c d}} c
@@ -345,13 +409,13 @@ test dict-11.13 {dict incr command} -returnCodes error -body {
dict incr dictv a a a
} -cleanup {
unset dictv
-} -result {wrong # args: should be "dict incr varName key ?increment?"}
+} -result {wrong # args: should be "dict incr dictVarName key ?increment?"}
test dict-11.14 {dict incr command} -returnCodes error -body {
set dictv a
dict incr dictv
} -cleanup {
unset dictv
-} -result {wrong # args: should be "dict incr varName key ?increment?"}
+} -result {wrong # args: should be "dict incr dictVarName key ?increment?"}
test dict-11.15 {dict incr command: write failure} -setup {
unset -nocomplain dictVar
} -body {
@@ -422,10 +486,10 @@ test dict-12.6 {dict lappend command} -returnCodes error -body {
} -result {missing value to go with key}
test dict-12.7 {dict lappend command} -returnCodes error -body {
dict lappend
-} -result {wrong # args: should be "dict lappend varName key ?value ...?"}
+} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"}
test dict-12.8 {dict lappend command} -returnCodes error -body {
dict lappend dictv
-} -result {wrong # args: should be "dict lappend varName key ?value ...?"}
+} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"}
test dict-12.9 {dict lappend command} -returnCodes error -body {
set dictv [dict create a "\{"]
dict lappend dictv a a
@@ -489,10 +553,10 @@ test dict-13.6 {dict append command} -returnCodes error -body {
} -result {missing value to go with key}
test dict-13.7 {dict append command} -returnCodes error -body {
dict append
-} -result {wrong # args: should be "dict append varName key ?value ...?"}
+} -result {wrong # args: should be "dict append dictVarName key ?value ...?"}
test dict-13.8 {dict append command} -returnCodes error -body {
dict append dictv
-} -result {wrong # args: should be "dict append varName key ?value ...?"}
+} -result {wrong # args: should be "dict append dictVarName key ?value ...?"}
test dict-13.9 {dict append command: write failure} -setup {
unset -nocomplain dictVar
} -body {
@@ -510,16 +574,16 @@ test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} {
test dict-14.1 {dict for command: syntax} -returnCodes error -body {
dict for
-} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.2 {dict for command: syntax} -returnCodes error -body {
dict for x
-} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.3 {dict for command: syntax} -returnCodes error -body {
dict for x x
-} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.4 {dict for command: syntax} -returnCodes error -body {
dict for x x x x
-} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"}
test dict-14.5 {dict for command: syntax} -returnCodes error -body {
dict for x x x
} -result {must have exactly two variable names}
@@ -749,13 +813,13 @@ test dict-15.9 {dict set command: write failure} -setup {
} -result {can't set "dictVar": variable is array}
test dict-15.10 {dict set command: syntax} -returnCodes error -body {
dict set
-} -result {wrong # args: should be "dict set varName key ?key ...? value"}
+} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.11 {dict set command: syntax} -returnCodes error -body {
dict set a
-} -result {wrong # args: should be "dict set varName key ?key ...? value"}
+} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.12 {dict set command: syntax} -returnCodes error -body {
dict set a a
-} -result {wrong # args: should be "dict set varName key ?key ...? value"}
+} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"}
test dict-15.13 {dict set command} -returnCodes error -body {
set dictVar a
dict set dictVar b c
@@ -808,7 +872,7 @@ test dict-16.7 {dict unset command} -setup {
} -result {0 {} 1}
test dict-16.8 {dict unset command} -returnCodes error -body {
dict unset dictVar
-} -result {wrong # args: should be "dict unset varName key ?key ...?"}
+} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"}
test dict-16.9 {dict unset command: write failure} -setup {
unset -nocomplain dictVar
} -body {
@@ -859,7 +923,7 @@ test dict-16.16 {dict unset command} -body {
} -result {0 {} 1}
test dict-16.17 {dict unset command} -returnCodes error -body {
apply {{} {dict unset dictVar}}
-} -result {wrong # args: should be "dict unset varName key ?key ...?"}
+} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"}
test dict-16.18 {dict unset command: write failure} -body {
apply {{} {
set dictVar(block) {}
@@ -988,7 +1052,7 @@ test dict-17.17 {dict filter command: script} -body {
} -result b
test dict-17.18 {dict filter command: script} -returnCodes error -body {
dict filter {a b} script {k k}
-} -result {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"}
+} -result {wrong # args: should be "dict filter dictionary script {keyVarName valueVarName} filterScript"}
test dict-17.19 {dict filter command: script} -returnCodes error -body {
dict filter {a b} script k {continue}
} -result {must have exactly two variable names}
@@ -1226,19 +1290,34 @@ test dict-20.19 {dict merge command} {
test dict-20.20 {dict merge command} {
apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}}
} {a - c d e f 1 - 3 4}
+test dict-20.21 {dict merge command: canonicality not forced} {
+ dict merge { a b c d }
+} { a b c d }
+test dict-20.22 {dict merge command: canonicality not forced} {
+ dict merge { a b c d } {}
+} { a b c d }
+test dict-20.23 {dict merge command: canonicality forced by update} {
+ dict merge { a b c d } {a b}
+} {a b c d}
+test dict-20.24 {dict merge command: type check is mandatory} -body {
+ dict merge { a b c d e }
+} -returnCodes error -result {missing value to go with key}
+test dict-20.25 {dict merge command: type check is mandatory} -body {
+ dict merge { a b {}c d }
+} -returnCodes error -result {dict element in braces followed by "c" instead of space}
test dict-21.1 {dict update command} -returnCodes 1 -body {
dict update
-} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
+} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.2 {dict update command} -returnCodes 1 -body {
dict update v
-} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
+} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.3 {dict update command} -returnCodes 1 -body {
dict update v k
-} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
+} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.4 {dict update command} -returnCodes 1 -body {
dict update v k v
-} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"}
+} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"}
test dict-21.5 {dict update command} -body {
set a {b c}
set result {}
@@ -1376,10 +1455,10 @@ test dict-21.17 {dict update command: no recursive structures [Bug 1786481]} {
test dict-22.1 {dict with command} -body {
dict with
-} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
+} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"}
test dict-22.2 {dict with command} -body {
dict with v
-} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"}
+} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"}
test dict-22.3 {dict with command} -body {
unset -nocomplain v
dict with v {error "in body"}
@@ -1639,16 +1718,16 @@ rename linenumber {}
test dict-24.1 {dict map command: syntax} -returnCodes error -body {
dict map
-} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.2 {dict map command: syntax} -returnCodes error -body {
dict map x
-} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.3 {dict map command: syntax} -returnCodes error -body {
dict map x x
-} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.4 {dict map command: syntax} -returnCodes error -body {
dict map x x x x
-} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"}
+} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"}
test dict-24.5 {dict map command: syntax} -returnCodes error -body {
dict map x x x
} -result {must have exactly two variable names}
diff --git a/tests/env.test b/tests/env.test
index fa76433..83d99e0 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -218,8 +218,8 @@ test env-4.5 {unsetting international environment variables} -setup {
unset env(\ua7)
getenv
} -constraints {exec} -cleanup {
- encoding system $sysenc
unset env(\ub6)
+ encoding system $sysenc
} -result {\u00b6=\u00a7}
test env-5.0 {corner cases - set a value, it should exist} -body {
@@ -291,6 +291,29 @@ test env-6.1 {corner cases - add lots of env variables} {} {
expr {[array size env] - $size}
} 100
+test env-7.1 {[219226]: whole env array should not be unset by read} {
+ set n [array size env]
+ set s [array startsearch env]
+ while {[array anymore env $s]} {
+ array nextelement env $s
+ incr n -1
+ }
+ array donesearch env $s
+ return $n
+} 0
+test env-7.2 {[219226]: links to env elements should not be removed by read} {
+ apply {{} {
+ set ::env(test7_2) ok
+ upvar env(test7_2) elem
+ set ::env(PATH)
+ try {
+ return $elem
+ } finally {
+ unset ::env(test7_2)
+ }
+ }}
+} ok
+
# Restore the environment variables at the end of the test.
foreach name [array names env] {
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/exec.test b/tests/exec.test
index 871c0c5..16a8320 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -370,7 +370,7 @@ err}
test exec-10.1 {errors in exec invocation} -constraints {exec} -body {
exec
-} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"}
+} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-10.2 {errors in exec invocation} -constraints {exec} -body {
exec | cat
} -returnCodes error -result {illegal use of | or |& in command}
@@ -545,10 +545,10 @@ test exec-14.1 {-keepnewline switch} {exec} {
} "foo\n"
test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
exec -keepnewline
-} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"}
+} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
test exec-14.3 {unknown switch} -constraints {exec} -body {
exec -gorp
-} -returnCodes error -result {bad switch "-gorp": must be -ignorestderr, -keepnewline, or --}
+} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
test exec-14.4 {-- switch} -constraints {exec} -body {
exec -- -gorp
} -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
diff --git a/tests/execute.test b/tests/execute.test
index 94af158..9a2ffbd 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -1043,6 +1043,29 @@ test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
} -cleanup {
interp delete slave
} -result ok
+
+test execute-11.2 {Bug 268b23df11} -setup {
+ proc zero {} {return 0}
+ proc crash {} {expr {abs([zero])}}
+ proc noop args {}
+ trace add execution crash enterstep noop
+} -body {
+ crash
+} -cleanup {
+ trace remove execution crash enterstep noop
+ rename noop {}
+ rename crash {}
+ rename zero {}
+} -result 0
+test execute-11.3 {Bug a0ece9d6d4} -setup {
+ proc crash {} {expr {rand()}}
+ trace add execution crash enterstep {apply {args {info frame -2}}}
+} -body {
+ string is double [crash]
+} -cleanup {
+ trace remove execution crash enterstep {apply {args {info frame -2}}}
+ rename crash {}
+} -result 1
# cleanup
if {[info commands testobj] != {}} {
diff --git a/tests/expr.test b/tests/expr.test
index 6ad7208..4c03262 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -7174,6 +7174,10 @@ test expr-50.1 {test sqrt() of bignums with non-Inf answer} {
expr {sqrt("1[string repeat 0 616]") == 1e308}
} 1
+test expr-51.1 {test round-to-even on input} {
+ expr 6.9294956446009195e15
+} 6929495644600920.0
+
# cleanup
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 8f27ad4..c8264b2 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -128,7 +128,7 @@ proc checkcontent {file matchString} {
}
proc openup {path} {
- testchmod 777 $path
+ testchmod 0o777 $path
if {[file isdirectory $path]} {
catch {
foreach p [glob -directory $path *] {
@@ -362,10 +362,10 @@ test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} -setup {
cleanup
} -constraints {unix notRoot testchmod} -returnCodes error -body {
file mkdir td1/td2/td3
- testchmod 000 td1/td2
+ testchmod 0 td1/td2
file mkdir td1/td2/td3/td4
} -cleanup {
- testchmod 755 td1/td2
+ testchmod 0o755 td1/td2
cleanup
} -result {can't create directory "td1/td2/td3": permission denied}
test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} -setup {
@@ -505,18 +505,12 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup {
cleanup
} -constraints {unix notRoot testchmod} -body {
file mkdir td1
- testchmod 000 td1
+ testchmod 0 td1
createfile tf1
file rename tf1 td1
} -returnCodes error -cleanup {
- testchmod 755 td1
+ testchmod 0o755 td1
} -result {error renaming "tf1" to "td1/tf1": permission denied}
-test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} -setup {
- cleanup
-} -constraints {win 95} -returnCodes error -body {
- createfile tf1
- file rename tf1 $long
-} -result [subst {error renaming "tf1" to "$long": file name too long}]
test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup {
cleanup
} -constraints {unix notRoot} -body {
@@ -791,7 +785,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup {
} -constraints {notRoot testchmod} -body {
createfile tf1
createfile tf2
- testchmod 444 tf2
+ testchmod 0o444 tf2
file rename tf1 tf3
file rename tf2 tf4
list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
@@ -800,7 +794,7 @@ test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup {
cleanup
} -constraints {win win2000orXP testchmod} -body {
file mkdir td1 td2
- testchmod 555 td2
+ testchmod 0o555 td2
file rename td1 td3
file rename td2 td4
list [lsort [glob td*]] [file writable td3] [file writable td4]
@@ -811,7 +805,7 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup {
cleanup
} -constraints {unix notRoot testchmod notDarwin9} -body {
file mkdir td1 td2
- testchmod 555 td2
+ testchmod 0o555 td2
file rename td1 td3
file rename td2 td4
list [lsort [glob td*]] [file writable td3] [file writable td4]
@@ -823,7 +817,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup {
} -constraints {notRoot testchmod} -body {
createfile tf1 tf1
createfile tf2 tf2
- testchmod 444 tf2
+ testchmod 0o444 tf2
file rename -force tf1 tf1
file rename -force tf2 tf2
list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
@@ -833,7 +827,7 @@ test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup {
} -constraints {win win2000orXP testchmod} -body {
file mkdir td1
file mkdir td2
- testchmod 555 td2
+ testchmod 0o555 td2
file rename -force td1 .
file rename -force td2 .
list [lsort [glob td*]] [file writable td1] [file writable td2]
@@ -843,7 +837,7 @@ test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup {
} -constraints {unix notRoot testchmod} -body {
file mkdir td1
file mkdir td2
- testchmod 555 td2
+ testchmod 0o555 td2
file rename -force td1 .
file rename -force td2 .
list [lsort [glob td*]] [file writable td1] [file writable td2]
@@ -861,10 +855,10 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup {
createfile tfd2
createfile tfd3
createfile tfd4
- testchmod 444 tfs3
- testchmod 444 tfs4
- testchmod 444 tfd2
- testchmod 444 tfd4
+ testchmod 0o444 tfs3
+ testchmod 0o444 tfs4
+ testchmod 0o444 tfd2
+ testchmod 0o444 tfd4
set msg [list [catch {file rename tf1 tf2} msg] $msg]
file rename -force tfs1 tfd1
file rename -force tfs2 tfd2
@@ -888,11 +882,11 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup {
file mkdir [file join tdd3 tds3]
file mkdir [file join tdd4 tds4]
if {![testConstraint unix]} {
- testchmod 555 tds3
- testchmod 555 tds4
+ testchmod 0o555 tds3
+ testchmod 0o555 tds4
}
- testchmod 555 [file join tdd2 tds2]
- testchmod 555 [file join tdd4 tds4]
+ testchmod 0o555 [file join tdd2 tds2]
+ testchmod 0o555 [file join tdd4 tds4]
set msg [list [catch {file rename td1 td2} msg] $msg]
file rename -force tds1 tdd1
file rename -force tds2 tdd2
@@ -917,7 +911,7 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup {
file mkdir [file join tdd1 tds1 xxx]
file mkdir [file join tdd2 tds2 xxx]
if {!([testConstraint unix] || [testConstraint winVista])} {
- testchmod 555 tds2
+ testchmod 0o555 tds2
}
set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg]
set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg]
@@ -935,7 +929,7 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup {
createfile tf1
createfile tf2
file mkdir td1
- testchmod 444 tf2
+ testchmod 0o444 tf2
file rename tf1 [file join td1 tf3]
file rename tf2 [file join td1 tf4]
list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \
@@ -948,7 +942,7 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup {
file mkdir td2
file mkdir td3
if {!([testConstraint unix] || [testConstraint winVista])} {
- testchmod 555 td2
+ testchmod 0o555 td2
}
file rename td1 [file join td3 td3]
file rename td2 [file join td3 td4]
@@ -964,13 +958,13 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup {
cleanup
} -constraints {notRoot testchmod notNetworkFilesystem} -body {
file mkdir [file join td1 td2] [file join td2 td1]
- testchmod 555 [file join td2 td1]
+ testchmod 0o555 [file join td2 td1]
file mkdir [file join td3 td4] [file join td4 td3]
file rename -force td3 td4
list [file exists td3] [file exists [file join td4 td3 td4]] \
[catch {file rename td1 td2} msg] $msg
} -cleanup {
- testchmod 755 [file join td2 td1]
+ testchmod 0o755 [file join td2 td1]
} -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}]
# Test can hit EEXIST or EBUSY, depending on underlying filesystem
test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup {
@@ -1041,7 +1035,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} -setup {
} -constraints {notRoot testchmod} -body {
createfile tf1 tf1
createfile tf2 tf2
- testchmod 444 tf2
+ testchmod 0o444 tf2
file copy tf1 tf3
file copy tf2 tf4
list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
@@ -1051,14 +1045,14 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup {
} -constraints {unix notRoot testchmod} -body {
file mkdir [file join td1 tdx]
file mkdir [file join td2 tdy]
- testchmod 555 td2
+ testchmod 0o555 td2
file copy td1 td3
file copy td2 td4
list [lsort [glob td*]] [glob -directory td3 t*] \
[glob -directory td4 t*] [file writable td3] [file writable td4]
} -cleanup {
- testchmod 755 td2
- testchmod 755 td4
+ testchmod 0o755 td2
+ testchmod 0o755 td4
} -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0]
test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup {
cleanup
@@ -1066,14 +1060,14 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup {
# On Windows with ACLs, copying a directory is defined like this
file mkdir [file join td1 tdx]
file mkdir [file join td2 tdy]
- testchmod 555 td2
+ testchmod 0o555 td2
file copy td1 td3
file copy td2 td4
list [lsort [glob td*]] [glob -directory td3 t*] \
[glob -directory td4 t*] [file writable td3] [file writable td4]
} -cleanup {
- testchmod 755 td2
- testchmod 755 td4
+ testchmod 0o755 td2
+ testchmod 0o755 td4
} -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1]
test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
cleanup
@@ -1088,10 +1082,10 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup {
createfile tfd2
createfile tfd3
createfile tfd4
- testchmod 444 tfs3
- testchmod 444 tfs4
- testchmod 444 tfd2
- testchmod 444 tfd4
+ testchmod 0o444 tfs3
+ testchmod 0o444 tfs4
+ testchmod 0o444 tfd2
+ testchmod 0o444 tfd4
set msg [list [catch {file copy tf1 tf2} msg] $msg]
file copy -force tfs1 tfd1
file copy -force tfs2 tfd2
@@ -1112,10 +1106,10 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup {
file mkdir [file join tdd2 tds2]
file mkdir [file join tdd3 tds3]
file mkdir [file join tdd4 tds4]
- testchmod 555 tds3
- testchmod 555 tds4
- testchmod 555 [file join tdd2 tds2]
- testchmod 555 [file join tdd4 tds4]
+ testchmod 0o555 tds3
+ testchmod 0o555 tds4
+ testchmod 0o555 [file join tdd2 tds2]
+ testchmod 0o555 [file join tdd4 tds4]
set a1 [list [catch {file copy td1 td2} msg] $msg]
set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg]
set a3 [catch {file copy -force tds2 tdd2}]
@@ -1130,7 +1124,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
file mkdir tds2
file mkdir [file join tdd1 tds1 xxx]
file mkdir [file join tdd2 tds2 xxx]
- testchmod 555 tds2
+ testchmod 0o555 tds2
set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]
@@ -1141,7 +1135,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup {
createfile tf1
createfile tf2
file mkdir td1
- testchmod 444 tf2
+ testchmod 0o444 tf2
file copy tf1 [file join td1 tf3]
file copy tf2 [file join td1 tf4]
list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \
@@ -1153,7 +1147,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup {
file mkdir td1
file mkdir td2
file mkdir td3
- testchmod 555 td2
+ testchmod 0o555 td2
file copy td1 [file join td3 td3]
file copy td2 [file join td3 td4]
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
@@ -1166,7 +1160,7 @@ test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup {
file mkdir td1
file mkdir td2
file mkdir td3
- testchmod 555 td2
+ testchmod 0o555 td2
file copy td1 [file join td3 td3]
file copy td2 [file join td3 td4]
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
@@ -2330,10 +2324,10 @@ test fCmd-28.2 {file link} -returnCodes error -body {
} -result {wrong # args: should be "file link ?-linktype? linkname ?target?"}
test fCmd-28.3 {file link} -returnCodes error -body {
file link abc b c
-} -result {bad switch "abc": must be -symbolic or -hard}
+} -result {bad option "abc": must be -symbolic or -hard}
test fCmd-28.4 {file link} -returnCodes error -body {
file link -abc b c
-} -result {bad switch "-abc": must be -symbolic or -hard}
+} -result {bad option "-abc": must be -symbolic or -hard}
cd [workingDirectory]
makeDirectory abc.dir
makeDirectory abc2.dir
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/for.test b/tests/for.test
index 8936682..8abd270 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -942,6 +942,248 @@ test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount}
expr {$end - $tmp}
}}
} 0
+test for-7.9 {Bug 3614226: ensure that break from invoked command cleans up the stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [apply {{} {return -code break}}] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.10 {Bug 3614226: ensure that continue from invoked command cleans up the stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [apply {{} {return -code continue}}] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.11 {Bug 3614226: ensure that break from invoked command cleans up the expansion stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[apply {{} {return -code break}}] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.12 {Bug 3614226: ensure that continue from invoked command cleans up the expansion stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[apply {{} {
+ return -code continue
+ }}] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.13 {Bug 3614226: ensure that break from invoked command cleans up the combination of main and expansion stack} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
+ return -code break
+ }}] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.14 {Bug 3614226: ensure that continue from invoked command cleans up the combination of main and expansion stack} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
+ return -code continue
+ }}] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.15 {Bug 3614226: ensure that break from invoked command only cleans up the right amount} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
+ return -code break
+ }}] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.16 {Bug 3614226: ensure that continue from invoked command only cleans up the right amount} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} {
+ return -code continue
+ }}] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.17 {Bug 3614226: ensure that break from expanded command cleans up the stack} memory {
+ apply {op {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [{*}$op] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code break}
+} 0
+test for-7.18 {Bug 3614226: ensure that continue from expanded command cleans up the stack} memory {
+ apply {op {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [{*}$op] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code continue}
+} 0
+test for-7.19 {Bug 3614226: ensure that break from expanded command cleans up the expansion stack} memory {
+ apply {op {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[{*}$op] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code break}
+} 0
+test for-7.20 {Bug 3614226: ensure that continue from expanded command cleans up the expansion stack} memory {
+ apply {op {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[{*}$op] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code continue}
+} 0
+test for-7.21 {Bug 3614226: ensure that break from expanded command cleans up the combination of main and expansion stack} memory {
+ apply {op {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code break}
+} 0
+test for-7.22 {Bug 3614226: ensure that continue from expanded command cleans up the combination of main and expansion stack} memory {
+ apply {op {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code continue}
+} 0
+test for-7.23 {Bug 3614226: ensure that break from expanded command only cleans up the right amount} memory {
+ apply {op {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code break}
+} 0
+test for-7.24 {Bug 3614226: ensure that continue from expanded command only cleans up the right amount} memory {
+ apply {op {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }} {return -level 0 -code continue}
+} 0
# cleanup
::tcltest::cleanupTests
diff --git a/tests/http.test b/tests/http.test
index 7d439b1..41820cb 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -119,7 +119,7 @@ test http-3.2 {http::geturl} -returnCodes error -body {
http::geturl http:junk
} -result {Unsupported URL: http:junk}
set url //[info hostname]:$port
-set badurl //[info hostname]:6666
+set badurl //[info hostname]:[expr $port+1]
test http-3.3 {http::geturl} -body {
set token [http::geturl $url]
http::data $token
@@ -131,7 +131,7 @@ test http-3.3 {http::geturl} -body {
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
-set fullurl http://user:pass@[info hostname]:$port/a/b/c
+set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
@@ -306,7 +306,6 @@ test http-3.13 {http::geturl socket leak test} {
for {set i 0} {$i < 3} {incr i} {
catch {http::geturl $badurl -timeout 5000}
}
-
# No extra channels should be taken
expr {[llength [file channels]] == $chanCount}
} 1
@@ -372,11 +371,11 @@ test http-3.27 {http::geturl: -headers override -type} -body {
http::data $token
} -cleanup {
http::cleanup $token
-} -match regexp -result {(?n)Accept \*/\*
-Host .*
+} -match regexp -result {(?n)Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
+Accept \*/\*
Accept-Encoding .*
Content-Length 5}
test http-3.28 {http::geturl: -headers override -type default} -body {
@@ -385,11 +384,11 @@ test http-3.28 {http::geturl: -headers override -type default} -body {
http::data $token
} -cleanup {
http::cleanup $token
-} -match regexp -result {(?n)Accept \*/\*
-Host .*
+} -match regexp -result {(?n)Host .*
User-Agent .*
Connection close
Content-Type {text/plain;charset=utf-8}
+Accept \*/\*
Accept-Encoding .*
Content-Length 5}
test http-3.29 {http::geturl IPv6 address} -body {
@@ -418,6 +417,21 @@ test http-3.31 {http::geturl fragment without path} -body {
} -cleanup {
catch { http::cleanup $token }
} -result 200
+# Bug c11a51c482
+test http-3.32 {http::geturl: -headers override -accept default} -body {
+ set token [http::geturl $url/headers -query dummy \
+ -headers [list "Accept" "text/plain,application/tcl-test-value"]]
+ http::data $token
+} -cleanup {
+ http::cleanup $token
+} -match regexp -result {(?n)Host .*
+User-Agent .*
+Connection close
+Accept text/plain,application/tcl-test-value
+Accept-Encoding .*
+Content-Type application/x-www-form-urlencoded
+Content-Length 5}
+
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
@@ -492,14 +506,10 @@ proc myProgress {token total current} {
}
set progress [list $total $current]
}
-if 0 {
- # This test hangs on Windows95 because the client never gets EOF
- set httpLog 1
- test http-4.6.1 {http::Event} knownBug {
- set token [http::geturl $url -blocksize 50 -progress myProgress]
- return $progress
- } {111 111}
-}
+test http-4.6.1 {http::Event} knownBug {
+ set token [http::geturl $url -blocksize 50 -progress myProgress]
+ return $progress
+} {111 111}
test http-4.7 {http::Event} -body {
set token [http::geturl $url -keepalive 0 -progress myProgress]
return $progress
diff --git a/tests/http11.test b/tests/http11.test
index 230ce5a..c9ded0b 100644
--- a/tests/http11.test
+++ b/tests/http11.test
@@ -70,11 +70,8 @@ proc check_crc {tok args} {
return "ok"
}
-makeFile "<html><head><title>test</title></head>\
-<body><p>this is a test</p>\n\
-[string repeat {<p>This is a tcl test file.</p>} 4192]\n\
-</body></html>" testdoc.html
-
+makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html
+
# -------------------------------------------------------------------------
test http11-1.0 "normal request for document " -setup {
@@ -447,7 +444,8 @@ test http11-2.10 "-channel,deflate,keepalive" -setup {
set chan [open [makeFile {} testfile.tmp] wb+]
} -body {
set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
- -timeout 5000 -channel $chan -keepalive 1]
+ -timeout 5000 -channel $chan -keepalive 1 \
+ -headers {accept-encoding deflate}]
http::wait $tok
seek $chan 0
set data [read $chan]
@@ -482,6 +480,27 @@ test http11-2.11 "-channel,identity,keepalive" -setup {
halt_httpd
} -result {ok {HTTP/1.1 200 OK} ok {} {} chunked}
+test http11-2.12 "-channel,negotiate,keepalive" -setup {
+ variable httpd [create_httpd]
+ set chan [open [makeFile {} testfile.tmp] wb+]
+} -body {
+ set tok [http::geturl http://localhost:$httpd_port/testdoc.html \
+ -timeout 5000 -channel $chan -keepalive 1]
+ http::wait $tok
+ seek $chan 0
+ set data [read $chan]
+ list [http::status $tok] [http::code $tok] [check_crc $tok $data]\
+ [meta $tok connection] [meta $tok content-encoding]\
+ [meta $tok transfer-encoding] [meta $tok x-requested-encodings]\
+ [expr {[file size testdoc.html]-[file size testfile.tmp]}]
+} -cleanup {
+ http::cleanup $tok
+ close $chan
+ removeFile testfile.tmp
+ halt_httpd
+} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0}
+
+
# -------------------------------------------------------------------------
#
# The following tests for the -handler option will require changes in
@@ -644,7 +663,7 @@ test http11-4.3 "normal post request, check channel query length" -setup {
removeFile testfile.tmp
halt_httpd
} -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880}
-
+
# -------------------------------------------------------------------------
foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl
index 9c543dc..267f409 100644
--- a/tests/httpd11.tcl
+++ b/tests/httpd11.tcl
@@ -158,13 +158,13 @@ proc Service {chan addr port} {
}
if {$protocol eq "HTTP/1.1"} {
- if {[string match "*deflate*" [dict get? $meta accept-encoding]]} {
- set encoding deflate
- } elseif {[string match "*gzip*" [dict get? $meta accept-encoding]]} {
- set encoding gzip
- } elseif {[string match "*compress*" [dict get? $meta accept-encoding]]} {
- set encoding compress
- }
+ foreach enc [split [dict get? $meta accept-encoding] ,] {
+ set enc [string trim $enc]
+ if {$enc in {deflate gzip compress}} {
+ set encoding $enc
+ break
+ }
+ }
set transfer chunked
} else {
set close 1
@@ -189,6 +189,7 @@ proc Service {chan addr port} {
if {$close} {
Puts $chan "connection: close"
}
+ Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
if {$encoding eq "identity"} {
Puts $chan "content-length: [string length $data]"
} else {
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 0688c14..6b6ad6d 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -13,14 +13,16 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[catch {package require tcltest 2}]} {
- puts stderr "Skipping tests in [info script]. tcltest 2 required."
- return
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
+testConstraint testbytestring [llength [info commands testbytestring]]
+
namespace eval ::tcl::test::io {
namespace import ::tcltest::*
@@ -45,7 +47,7 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
-testConstraint largefileSupport 0
+testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
@@ -1449,6 +1451,105 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee
lappend x [catch {close $f} msg] $msg
set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"
+test io-12.6 {ReadChars: too many chars read} {
+ 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 20][string repeat . 20]]
+ 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 15
+ }
+ 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-12.8 {ReadChars: multibyte chars split} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation binary
+ puts -nonewline $f [string repeat a 9]\xc2\xa0
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -encoding utf-8 -buffersize 10
+ set in [read $f]
+ close $f
+ scan [string index $in end] %c
+} 160
+test io-12.9 {ReadChars: multibyte chars split} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation binary
+ puts -nonewline $f [string repeat a 9]\xc2
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -encoding utf-8 -buffersize 10
+ set in [read $f]
+ close $f
+ scan [string index $in end] %c
+} 194
+test io-12.10 {ReadChars: multibyte chars split} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation binary
+ puts -nonewline $f [string repeat a 9]\xc2
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -encoding utf-8 -buffersize 11
+ set in [read $f]
+ close $f
+ scan [string index $in end] %c
+} 194
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
@@ -1563,6 +1664,45 @@ test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
close $f
set x
} "abcd\ndef"
+test io-13.8.1 {TranslateInputEOL: auto mode: \r\n} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation lf
+ puts -nonewline $f "abcd\r\ndef"
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -translation auto
+ set x {}
+ lappend x [read $f 5]
+ lappend x [read $f]
+ close $f
+ set x
+} [list "abcd\n" "def"]
+test io-13.8.2 {TranslateInputEOL: auto mode: \r\n} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation lf
+ puts -nonewline $f "abcd\r\ndef"
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -translation auto -buffersize 6
+ set x {}
+ lappend x [read $f 5]
+ lappend x [read $f]
+ close $f
+ set x
+} [list "abcd\n" "def"]
+test io-13.8.3 {TranslateInputEOL: auto mode: \r\n} {
+ set f [open $path(test1) w]
+ fconfigure $f -translation lf
+ puts -nonewline $f "abcd\r\n\r\ndef"
+ close $f
+ set f [open $path(test1)]
+ fconfigure $f -translation auto -buffersize 7
+ set x {}
+ lappend x [read $f 5]
+ lappend x [read $f]
+ close $f
+ set x
+} [list "abcd\n" "\ndef"]
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
@@ -2771,7 +2911,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa
variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
- for {set i 0} {$i < 2000} {incr i} {
+ for {set i 0} {$i < 9000} {incr i} {
puts $s $l
}
}
@@ -2802,7 +2942,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa
close $ss
vwait [namespace which -variable x]
set c
-} 2000
+} 9000
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
# On Mac, this test screws up sockets such that subsequent tests using port 2828
# either cause errors or panic().
@@ -3984,6 +4124,46 @@ test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} {
} {{hello
} {hello
}}
+test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} {
+ file delete $path(pipe)
+ set f1 [open $path(pipe) w]
+ puts $f1 {chan configure stdout -translation crlf}
+ puts $f1 {puts [gets stdin]}
+ puts $f1 {puts [gets stdin]}
+ close $f1
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
+ puts $f1 hello
+ flush $f1
+ set x ""
+ lappend x [read $f1 6]
+ puts $f1 hello
+ flush $f1
+ lappend x [read $f1]
+ close $f1
+ set x
+} {{hello
+} {hello
+}}
+test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} {
+ file delete $path(pipe)
+ set f1 [open $path(pipe) w]
+ puts $f1 {chan configure stdout -translation crlf}
+ puts $f1 {puts [gets stdin]}
+ puts $f1 {puts [gets stdin]}
+ close $f1
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
+ puts $f1 hello
+ flush $f1
+ set x ""
+ lappend x [read $f1 6]
+ puts $f1 hello
+ flush $f1
+ lappend x [read $f1]
+ close $f1
+ set x
+} {{hello
+} {hello
+}}
test io-32.12 {Tcl_Read, -nonewline} {
file delete $path(test1)
set f1 [open $path(test1) w]
@@ -4178,6 +4358,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.
@@ -4457,10 +4741,10 @@ test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
puts -nonewline $f abcdef
lappend l [tell $f]
close $f
- lappend l [file size $f]
+ lappend l [file size $path(test3)]
# truncate...
close [open $path(test3) w]
- lappend l [file size $f]
+ lappend l [file size $path(test3)]
set l
} {0 6 6 4294967296 4294967302 4294967302 0}
@@ -4725,6 +5009,92 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
close $f
list $c $l $e
} {21 8 1}
+test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr
+ puts $f abc\ndef
+ close $f
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $s $l $e [scan [string index $in end] %c]
+} -result {8 8 1 13}
+test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr -eofchar \x1a
+ puts $f abc\ndef
+ close $f
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf -eofchar \x1a
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $s $l $e [scan [string index $in end] %c]
+} -result {9 8 1 13}
+test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr -eofchar \x1a
+ puts $f {}
+ close $f
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf -eofchar \x1a
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $s $l $e [scan [string index $in end] %c]
+} -result {2 1 1 13}
+test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr
+ puts $f {}
+ close $f
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $s $l $e [scan [string index $in end] %c]
+} -result {1 1 1 13}
+test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr -eofchar {}
+ set i [format abc\ndef\n%cqrs\nuvw 26]
+ puts $f $i
+ close $f
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf -eofchar \x1a
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $c $l $e [scan [string index $in end] %c]
+} -result {17 8 1 13}
+test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} {
+ file delete $path(test1)
+ set f [open $path(test1) w]
+ fconfigure $f -translation cr -eofchar {}
+ set i [format \n%cqrsuvw 26]
+ puts $f $i
+ close $f
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
+ fconfigure $f -translation crlf -eofchar \x1a
+ set l [string length [set in [read $f]]]
+ set e [eof $f]
+ close $f
+ list $c $l $e [scan [string index $in end] %c]
+} {9 1 1 13}
# Test Tcl_InputBlocked
@@ -4747,6 +5117,29 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
close $f1
set x
} {{} 1 hello 0 {} 1}
+test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} {
+ set f1 [open "|[list [interpreter]]" r+]
+ chan configure $f1 -encoding binary -translation lf -eofchar {}
+ puts $f1 {
+ chan configure stdout -encoding binary -translation lf -eofchar {}
+ puts hello_from_pipe
+ }
+ flush $f1
+ gets $f1
+ fconfigure $f1 -blocking off -buffering full
+ puts $f1 {puts hello}
+ set x ""
+ lappend x [gets $f1]
+ lappend x [fblocked $f1]
+ flush $f1
+ after 200
+ lappend x [gets $f1]
+ lappend x [fblocked $f1]
+ lappend x [gets $f1]
+ lappend x [fblocked $f1]
+ close $f1
+ set x
+} {{} 1 hello 0 {} 1}
test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
fconfigure $f1 -buffering line
@@ -6564,11 +6957,23 @@ test io-52.4 {TclCopyChannel} {fcopy} {
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
- set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
+ set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
+ close $f1
+ close $f2
+ lappend result [file size $path(test1)]
+} {0 0 0 40}
+test io-52.4.1 {TclCopyChannel} {fcopy} {
+ file delete $path(test1)
+ set f1 [open $thisScript]
+ set f2 [open $path(test1) w]
+ fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000
+ fconfigure $f2 -translation cr -blocking 0
+ fcopy $f1 $f2 -size 40
+ set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
lappend result [file size $path(test1)]
-} {0 0 40}
+} {0 0 0 40}
test io-52.5 {TclCopyChannel, all} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
@@ -6754,6 +7159,150 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} {
file size $path(kyrillic.txt)
} 3
+test io-52.12 {coverage of -translation auto} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8
+ set out [open $path(test2) w]
+ chan configure $out -translation lf
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 29
+test io-52.13 {coverage of -translation cr} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation cr
+ set out [open $path(test2) w]
+ chan configure $out -translation lf
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 30
+test io-52.14 {coverage of -translation crlf} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation crlf
+ set out [open $path(test2) w]
+ chan configure $out -translation lf
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 29
+test io-52.14.1 {coverage of -translation crlf} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation crlf
+ set out [open $path(test2) w]
+ fcopy $in $out -size 2
+ close $in
+ close $out
+ file size $path(test2)
+} 2
+test io-52.14.2 {coverage of -translation crlf} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -translation crlf
+ set out [open $path(test2) w]
+ fcopy $in $out -size 9
+ close $in
+ close $out
+ file size $path(test2)
+} 9
+test io-52.15 {coverage of -translation crlf} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\r
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation crlf
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 8
+test io-52.16 {coverage of eofChar handling} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation lf -eofchar a
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 0
+test io-52.17 {coverage of eofChar handling} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation lf -eofchar d
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 3
+test io-52.18 {coverage of eofChar handling} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 8 -translation crlf -eofchar h
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 8
+test io-52.19 {coverage of eofChar handling} {
+ file delete $path(test1) $path(test2)
+ set out [open $path(test1) wb]
+ chan configure $out -translation lf
+ puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
+ close $out
+ set in [open $path(test1)]
+ chan configure $in -buffersize 10 -translation crlf -eofchar h
+ set out [open $path(test2) w]
+ fcopy $in $out
+ close $in
+ close $out
+ file size $path(test2)
+} 8
+
test io-53.1 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
@@ -6823,17 +7372,12 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven
for {set x 0} {$x < 12} {incr x} {
append big $big
}
- file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts ready
fcopy stdin stdout -command { set x }
vwait x
- set f [open $path(test1) w]
- fconfigure $f -translation lf
- puts $f "done"
- close $f
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
@@ -6841,11 +7385,10 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven
fconfigure $f1 -blocking 0
puts $f1 $big
flush $f1
- after 500
set result ""
fileevent $f1 read [namespace code {
append result [read $f1 1024]
- if {[string length $result] >= [string length $big]} {
+ if {[string length $result] >= [string length $big]+1} {
set x done
}
}]
@@ -6854,6 +7397,38 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven
set big {}
set x
} done
+test io-53.4.1 {Bug 894da183c8} {stdio fcopy} {
+ set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
+ variable x
+ for {set x 0} {$x < 12} {incr x} {
+ append big $big
+ }
+ file delete $path(pipe)
+ set f1 [open $path(pipe) w]
+ puts $f1 [list file delete $path(test1)]
+ puts $f1 {
+ puts ready
+ set f [open io-53.4.1 w]
+ chan configure $f -translation lf
+ fcopy stdin $f -command { set x }
+ vwait x
+ close $f
+ }
+ puts $f1 "close \[[list open $path(test1) w]]"
+ close $f1
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
+ set result [gets $f1]
+ fconfigure $f1 -blocking 0 -buffersize 125000 -translation lf
+ puts $f1 $big
+ fconfigure $f1 -blocking 1
+ close $f1
+ set big {}
+ while {[catch {glob $path(test1)}]} {after 50}
+ file delete $path(test1)
+ set check [file size io-53.4.1]
+ file delete io-53.4.1
+ set check
+} 266241
set result {}
proc FcopyTestAccept {sock args} {
after 1000 "close $sock"
@@ -7223,6 +7798,211 @@ test io-53.11 {Bug 2895565} -setup {
removeFile out
removeFile in
} -result {40 bytes copied}
+test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} {
+ file delete $path(pipe)
+ set f1 [open $path(pipe) w]
+ puts -nonewline $f1 {
+ fconfigure stdin -translation binary -blocking 0
+ fconfigure stdout -buffering none -translation binary
+ fcopy stdin stdout
+ }
+ close $f1
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
+ fconfigure $f1 -translation binary -buffering none
+ puts -nonewline $f1 A
+ after 2000 {set ::done timeout}
+ fileevent $f1 readable {set ::done ok}
+ vwait ::done
+ set ch [read $f1 1]
+ close $f1
+ list $::done $ch
+} {ok A}
+test io-53.13 {TclCopyChannel: read error reporting} -setup {
+ proc driver {cmd args} {
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ return {initialize finalize watch read}
+ }
+ finalize {
+ return
+ }
+ watch {}
+ read {
+ error FAIL
+ }
+ }
+ }
+ set outFile [makeFile {} out]
+} -body {
+ set in [chan create read [namespace which driver]]
+ chan configure $in -translation binary
+ set out [open $outFile wb]
+ chan copy $in $out
+} -cleanup {
+ catch {close $in}
+ catch {close $out}
+ removeFile out
+ rename driver {}
+} -result {error reading "*": *} -returnCodes error -match glob
+test io-53.14 {TclCopyChannel: write error reporting} -setup {
+ proc driver {cmd args} {
+ variable buffer
+ variable index
+ set chan [lindex $args 0]
+ switch -- $cmd {
+ initialize {
+ return {initialize finalize watch write}
+ }
+ finalize {
+ return
+ }
+ watch {}
+ write {
+ error FAIL
+ }
+ }
+ }
+ set inFile [makeFile {aaa} in]
+} -body {
+ set in [open $inFile rb]
+ set out [chan create write [namespace which driver]]
+ chan configure $out -translation binary
+ chan copy $in $out
+} -cleanup {
+ catch {close $in}
+ catch {close $out}
+ 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-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup {
+ 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 \
+ line\n[string repeat a 100]line\n]
+ 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 -translation lf -buffersize 107
+ set out [makeFile {} out]
+ set outChan [open $out w]
+ chan configure $outChan -encoding utf-8 -translation lf
+} -body {
+ list [gets $c] [chan copy $c $outChan -size 100] [gets $c]
+} -cleanup {
+ close $outChan
+ close $c
+ removeFile out
+} -result {line 100 line}
test io-54.1 {Recursive channel events} {socket fileevent} {
# This test checks to see if file events are delivered during recursive
@@ -7473,12 +8253,12 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
string equal $result [testmainthread]
} {1}
-test io-60.1 {writing illegal utf sequences} {openpipe fileevent} {
+test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out {
- puts [encoding convertfrom identity \xe2]
+ puts [testbytestring \xe2]
exit 1
}
proc readit {pipe} {
@@ -7788,6 +8568,64 @@ 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}
+
+test io-73.4 {[5adc350683] [read] after EOF} -setup {
+ set fn [makeFile {} io-73.4]
+ 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 [read $rfd]
+ lappend result [eof $rfd]
+} -cleanup {
+ close $wfd
+ close $rfd
+ removeFile io-73.4
+} -result {1 1 {more data
+} 1}
+
+test io-73.5 {effect of eof on encoding end flags} -setup {
+ set fn [makeFile {} io-73.5]
+ set rfd [open $fn r]
+ set wfd [open $fn a]
+ chan configure $wfd -buffering none -translation binary
+ chan configure $rfd -buffersize 5 -encoding utf-8
+ read $rfd
+} -body {
+ set result [eof $rfd]
+ puts -nonewline $wfd "more\u00c2\u00a0data"
+ lappend result [eof $rfd]
+ lappend result [read $rfd]
+ lappend result [eof $rfd]
+} -cleanup {
+ close $wfd
+ close $rfd
+ removeFile io-73.5
+} -result [list 1 1 more\u00a0data 1]
+
# ### ### ### ######### ######### #########
# cleanup
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 03242be..4fbc380 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -294,7 +294,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr
close $srv
unset cli srv port
rename iocmdSRV {}
-} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname}
+} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname}
test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
@@ -639,7 +639,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile foo bar} msg] $msg
-} {1 {bad switch "foo": must be -size or -command}}
+} {1 {bad option "foo": must be -size or -command}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
@@ -793,6 +793,90 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g
rename foo {}
set res
} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}
+test iocmd-21.20 {Bug 88aef05cda} -setup {
+ proc foo {method chan args} {
+ switch -- $method blocking {
+ chan configure $chan -blocking [lindex $args 0]
+ return
+ } initialize {
+ return {initialize finalize watch blocking read write
+ configure cget cgetall}
+ } finalize {
+ return
+ }
+ }
+ set ch [chan create {read write} foo]
+} -body {
+ list [catch {chan configure $ch -blocking 0} m] $m
+} -cleanup {
+ close $ch
+ rename foo {}
+} -match glob -result {1 {*nested eval*}}
+test iocmd-21.21 {[close] in [read] segfaults} -setup {
+ proc foo {method chan args} {
+ switch -- $method initialize {
+ return {initialize finalize watch read}
+ } finalize {} watch {} read {
+ close $chan
+ return a
+ }
+ }
+ set ch [chan create read foo]
+} -body {
+ read $ch 0
+} -cleanup {
+ close $ch
+ rename foo {}
+} -result {}
+test iocmd-21.22 {[close] in [read] segfaults} -setup {
+ proc foo {method chan args} {
+ switch -- $method initialize {
+ return {initialize finalize watch read}
+ } finalize {} watch {} read {
+ catch {close $chan}
+ return a
+ }
+ }
+ set ch [chan create read foo]
+} -body {
+ read $ch 1
+} -returnCodes error -cleanup {
+ catch {close $ch}
+ rename foo {}
+} -match glob -result {*invalid argument*}
+test iocmd-21.23 {[close] in [gets] segfaults} -setup {
+ proc foo {method chan args} {
+ switch -- $method initialize {
+ return {initialize finalize watch read}
+ } finalize {} watch {} read {
+ catch {close $chan}
+ return \n
+ }
+ }
+ set ch [chan create read foo]
+} -body {
+ gets $ch
+} -cleanup {
+ catch {close $ch}
+ rename foo {}
+} -result {}
+test iocmd-21.24 {[close] in binary [gets] segfaults} -setup {
+ proc foo {method chan args} {
+ switch -- $method initialize {
+ return {initialize finalize watch read}
+ } finalize {} watch {} read {
+ catch {close $chan}
+ return \n
+ }
+ }
+ set ch [chan create read foo]
+} -body {
+ chan configure $ch -translation binary
+ gets $ch
+} -cleanup {
+ catch {close $ch}
+ rename foo {}
+} -result {}
# --- --- --- --------- --------- ---------
# Helper commands to record the arguments to handler methods.
@@ -1051,6 +1135,20 @@ test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glo
rename foo {}
unset res
} -result {{read rc* 4096} {} 0}
+test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ set args [lassign $args sub id]
+ if {$sub ne "read"} {return}
+ close $id
+ return {}
+ }
+ set c [chan create {r} foo]
+ note [read $c]
+ rename foo {}
+ set res
+} -result {{read rc* 4096} {}}
# --- === *** ###########################
# method write
@@ -1978,13 +2076,13 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
proc foo {args} {
oninit; onfinal; track;
# destroy interpreter during channel access
- # Actually not possible for an interp to destroy itself.
- interp delete {}
- return}
+ suicide
+ }
set chan [chan create {r w} foo]
fconfigure $chan -buffering none
set chan
}]
+ interp alias $ida suicide {} interp delete $ida
# Move channel to 2nd thread.
interp eval $ida [list testchannel cut $chan]
@@ -2002,8 +2100,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
set res
}]
set res
-} -constraints {testchannel impossible} \
- -result {Owner lost}
+} -constraints {testchannel} -result {Owner lost}
test iocmd-32.2 {delete interp of reflected chan} {
# Bug 3034840
@@ -2651,10 +2748,9 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \
init* {set ret {initialize finalize watch read}}
watch {
set l [lindex $args 0]
+ catch {after cancel $::timer}
if {[llength $l]} {
set ::timer [after $::drive [list POST $ch]]
- } else {
- after cancel $::timer
}
}
finalize {
@@ -2717,7 +2813,9 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \
update
}
LOG THREAD-LOOP-DONE
- thread::exit
+ #thread::exit
+ # Thread exits cause leaks; Use clean thread shutdown
+ set forever yourGirl
}
LOG MAIN_WAITING
@@ -2726,10 +2824,11 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \
set res
} -cleanup {
+ after cancel $::timer
rename LOG {}
rename POST {}
rename HANDLER {}
- unset beat drive data forever res tid ch
+ unset beat drive data forever res tid ch timer
} -match glob \
-result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}}
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 5a8874c..e179eab 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -539,7 +539,46 @@ test iortrans-4.8 {chan read, read, bug 2921116} -setup {
tempdone
rename foo {}
} -result {{read rt* {test data
-}} file*}
+}} {}}
+test iortrans-4.8.1 {chan read, bug 721ec69271} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {fd args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ chan configure $c -buffersize 2
+ lappend res [read $c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* te} {read rt* st} {read rt* { d}} {read rt* at} {read rt* {a
+}} {}}
+test iortrans-4.8.2 {chan read, bug 721ec69271} -setup {
+ set res {}
+} -match glob -body {
+ proc foo {fd args} {
+ handle.initialize
+ handle.finalize
+ lappend ::res $args
+ # Kill and recreate transform while it is operating
+ chan pop $fd
+ chan push $fd [list foo $fd]
+ return x
+ }
+ set c [chan push [set c [tempchan]] [list foo $c]]
+ chan configure $c -buffersize 1
+ lappend res [read $c]
+} -cleanup {
+ tempdone
+ rename foo {}
+} -result {{read rt* t} {read rt* e} {read rt* s} {read rt* t} {read rt* { }} {read rt* d} {read rt* a} {read rt* t} {read rt* a} {read rt* {
+}} {}}
test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
set res {}
} -match glob -body {
@@ -557,7 +596,180 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup {
tempdone
rename foo {}
} -result {{read rt* {test data
-}} file*}
+}} {}}
+
+# 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)
@@ -995,22 +1207,24 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
# Magic to get the test* commands in the slaves
load {} Tcltest $ida
load {} Tcltest $idb
-} -constraints {testchannel impossible} -match glob -body {
+} -constraints {testchannel} -match glob -body {
# Set up channel in thread
set chan [interp eval $ida $helperscript]
+ interp eval $ida [list ::variable tempchan [tempchan]]
+ interp transfer {} $::tempchan $ida
set chan [interp eval $ida {
proc foo {args} {
handle.initialize clear drain flush limit? read write
handle.finalize
lappend ::res $args
- # Destroy interpreter during channel access. Actually not
- # possible for an interp to destroy itself.
- interp delete {}
- return}
- set chan [chan push [tempchan] foo]
+ # Destroy interpreter during channel access.
+ suicide
+ }
+ set chan [chan push $tempchan foo]
fconfigure $chan -buffering none
set chan
}]
+ interp alias $ida suicide {} interp delete $ida
# Move channel to 2nd thread, transform goes with it.
interp eval $ida [list testchannel cut $chan]
interp eval $idb [list testchannel splice $chan]
diff --git a/tests/iogt.test b/tests/iogt.test
index d4c31d2..1ed89f7 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -220,6 +220,36 @@ proc id_fulltrail {var op data} {
return $res
}
+proc id_torture {chan op data} {
+ switch -- $op {
+ create/write -
+ create/read -
+ delete/write -
+ delete/read -
+ clear_read {;#ignore}
+ flush/write -
+ flush/read {}
+ write {
+ global level
+ if {$level} {
+ return
+ }
+ incr level
+ testchannel unstack $chan
+ testchannel transform $chan \
+ -command [namespace code [list id_torture $chan]]
+ return $data
+ }
+ read {
+ testchannel unstack $chan
+ testchannel transform $chan \
+ -command [namespace code [list id_torture $chan]]
+ return $data
+ }
+ query/maxRead {return -1}
+ }
+}
+
proc counter {var op data} {
namespace upvar [namespace current] $var n
@@ -280,7 +310,7 @@ proc counter_audit {var vtrail op data} {
}
proc rblocks {var vtrail n op data} {
- namespace upvar [namespace current] $var n $vtrail trail
+ namespace upvar [namespace current] $var buf $vtrail trail
set res {}
@@ -326,6 +356,11 @@ proc audit_ops {var -attach channel} {
proc audit_flow {var -attach channel} {
testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
}
+
+proc torture {-attach channel} {
+ testchannel transform $channel -command [namespace code [list id_torture $channel]]
+}
+
proc stopafter {var n -attach channel} {
namespace upvar [namespace current] $var vn
set vn $n
@@ -445,6 +480,7 @@ query/maxRead
read
query/maxRead
flush/read
+query/maxRead
delete/read
--------
create/write
@@ -491,6 +527,7 @@ read {
}
query/maxRead {} -1
flush/read {} {}
+query/maxRead {} -1
delete/read {} *ignored*
--------
create/write {} *ignored*
@@ -542,15 +579,35 @@ write %^&*()_+-= %^&*()_+-=
write {
} {
}
+query/maxRead {} -1
delete/read {} *ignored*
flush/write {} {}
delete/write {} *ignored*}
+test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
+ set fh [open $path(dummy) r]
+ torture -attach $fh
+ chan configure $fh -buffersize 2
+ set x [read $fh]
+ testchannel unstack $fh
+ close $fh
+ set x
+} {}
+test iogt-2.5 {basic I/O, mixed trail} {testchannel} {
+ set ::level 0
+ set fh [open $path(dummyout) w]
+ torture -attach $fh
+ puts -nonewline $fh abcdef
+ flush $fh
+ testchannel unstack $fh
+ close $fh
+} {}
+
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
proc DoneCopy {n {err {}}} {
variable copy 1
}
-} -constraints {testchannel hangs} -body {
+} -constraints {testchannel knownBug} -body {
# This test to check the validity of aquired Tcl_Channel references is not
# possible because even a backgrounded fcopy will immediately start to
# copy data, without waiting for the event loop. This is done only in case
@@ -561,6 +618,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
# delay, causing the fcopy to underflow immediately.
set fin [open $path(dummy) r]
fevent 1000 500 {20 20 20 10 1 1} {
+ variable copy
close $fin
set fout [open dummyout w]
flush $sock; # now, or fcopy will error us out
@@ -594,23 +652,30 @@ test iogt-4.0 {fileevent readable, after transform} -setup {
proc Done {args} {
variable stop 1
}
-} -constraints {testchannel hangs} -body {
+ proc Get {sock} {
+ variable trail
+ variable got
+ if {[eof $sock]} {
+ Done
+ lappend trail "xxxxxxxxxxxxx"
+ close $sock
+ return
+ }
+ lappend trail "vvvvvvvvvvvvv"
+ lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
+ lappend trail "============="
+ #puts stdout $__ ; flush stdout
+ #read $sock
+ }
+
+} -constraints {testchannel knownBug} -body {
fevent 1000 500 {20 20 20 10 1} {
+ variable stop
audit_flow trail -attach $sock
rblocks_t rbuf trail 23 -attach $sock
- fileevent $sock readable [namespace code {
- if {[eof $sock]} {
- Done
- lappend trail "xxxxxxxxxxxxx"
- close $sock
- } else {
- lappend trail "vvvvvvvvvvvvv"
- lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
- lappend trail "============="
- #puts stdout $__; flush stdout
- #read $sock
- }
- }]
+
+ fileevent $sock readable [namespace code [list Get $sock]]
+
flush $sock; # Now, or fcopy will error us out
# But the 1 second delay should be enough to initialize everything
# else here.
@@ -619,6 +684,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup {
join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
} -cleanup {
rename Done {}
+ rename Get {}
} -result {[[]]
[[abcdefghijklmnopqrstuvw]]
[[xyz0123456789,./?><;'\|]]
@@ -706,7 +772,7 @@ test iogt-5.0 {EOF simulation} -setup {
set fin [open $path(dummy) r]
set fout [open $path(dummyout) w]
set trail [list]
-} -constraints {testchannel unknownFailure} -result {
+} -constraints {testchannel knownBug} -result {
audit_flow trail -attach $fin
stopafter_audit d trail 20 -attach $fin
audit_flow trail -attach $fout
@@ -785,6 +851,15 @@ test iogt-6.0 {Push back} -constraints testchannel -body {
close $f
} -result {xxx}
test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {
+
+ # This test demonstrates the bug/misfeature in the stacked
+ # channel implementation that data can be discarded if it is
+ # read into the buffers of one channel in the stack, and then
+ # that channel is popped before anything above it reads.
+ #
+ # This bug can be worked around by always setting -buffersize
+ # to 1, but who wants to do that?
+
set f [open $path(dummy) r]
# contents of dummy = "abcdefghi..."
read $f 3; # skip behind "abc"
@@ -796,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/load.test b/tests/load.test
index cded85d..9536271 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -215,6 +215,12 @@ test load-10.1 {load from vfs} \
-body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \
-result {0 {}} \
-cleanup {testsimplefilesystem 0; cd $dir; unset dir}
+
+test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \
+ [list $dll $loaded] {
+ load [file join $testDir pkgooa$ext]
+ list [pkgooa_stubsok] [lsort [info commands pkgooa_*]]
+} {1 pkgooa_stubsok}
# cleanup
unset ext
diff --git a/tests/lreplace.test b/tests/lreplace.test
index 5f675bc..e66a331 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,63 @@ 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
+} {}
+test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} {
+ lreplace { } 1 1
+} {}
+test lreplace-4.3 {lreplace edge case} {
+ lreplace {1 2 3} 2 0
+} {1 2 3}
+test lreplace-4.4 {lreplace edge case} {
+ lreplace {1 2 3 4 5} 3 1
+} {1 2 3 4 5}
+test lreplace-4.5 {lreplace edge case} {
+ lreplace {1 2 3 4 5} 3 0 _
+} {1 2 3 _ 4 5}
+test lreplace-4.6 {lreplace end-x: bug a4cb3f06c4} {
+ lreplace {0 1 2 3 4} 0 end-2
+} {3 4}
+test lreplace-4.6.1 {lreplace end-x: bug a4cb3f06c4} {
+ lreplace {0 1 2 3 4} 0 end-2 a b c
+} {a b c 3 4}
+test lreplace-4.7 {lreplace with two end-indexes: increasing} {
+ lreplace {0 1 2 3 4} end-2 end-1
+} {0 1 4}
+test lreplace-4.7.1 {lreplace with two end-indexes: increasing} {
+ lreplace {0 1 2 3 4} end-2 end-1 a b c
+} {0 1 a b c 4}
+test lreplace-4.8 {lreplace with two end-indexes: equal} {
+ lreplace {0 1 2 3 4} end-2 end-2
+} {0 1 3 4}
+test lreplace-4.8.1 {lreplace with two end-indexes: equal} {
+ lreplace {0 1 2 3 4} end-2 end-2 a b c
+} {0 1 a b c 3 4}
+test lreplace-4.9 {lreplace with two end-indexes: decreasing} {
+ lreplace {0 1 2 3 4} end-2 end-3
+} {0 1 2 3 4}
+test lreplace-4.9.1 {lreplace with two end-indexes: decreasing} {
+ lreplace {0 1 2 3 4} end-2 end-3 a b c
+} {0 1 a b c 2 3 4}
+test lreplace-4.10 {lreplace with two equal indexes} {
+ lreplace {0 1 2 3 4} 2 2
+} {0 1 3 4}
+test lreplace-4.10.1 {lreplace with two equal indexes} {
+ lreplace {0 1 2 3 4} 2 2 a b c
+} {0 1 a b c 3 4}
+test lreplace-4.11 {lreplace end index first} {
+ lreplace {0 1 2 3 4} end-2 1 a b c
+} {0 1 a b c 2 3 4}
+test lreplace-4.12 {lreplace end index first} {
+ lreplace {0 1 2 3 4} end-2 2 a b c
+} {0 1 a b c 3 4}
+
# cleanup
catch {unset foo}
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 050b592..6b965d1 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -17,8 +17,8 @@ if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
-if {[catch {package require msgcat 1.5}]} {
- puts stderr "Skipping tests in [info script]. No msgcat 1.5 found to test."
+if {[catch {package require msgcat 1.6}]} {
+ puts stderr "Skipping tests in [info script]. No msgcat 1.6 found to test."
return
}
@@ -32,6 +32,8 @@ namespace eval ::msgcat::test {
# Tests msgcat-0.*: locale initialization
+ # Calculate set of all permutations of a list
+ # PowerSet {1 2 3} -> {1 2 3} {2 3} {1 3} 3 {1 2} 2 1 {}
proc PowerSet {l} {
if {[llength $l] == 0} {return [list [list]]}
set element [lindex $l 0]
@@ -412,9 +414,14 @@ namespace eval ::msgcat::test {
foreach loc {foo foo_BAR foo_BAR_baz} {
test msgcat-5.$count {mcload} -setup {
variable locale [mclocale]
+ ::msgcat::mclocale ""
+ ::msgcat::mcloadedlocales clear
+ ::msgcat::mcpackageconfig unset mcfolder
mclocale $loc
} -cleanup {
mclocale $locale
+ ::msgcat::mcloadedlocales clear
+ ::msgcat::mcpackageconfig unset mcfolder
} -body {
mcload $msgdir
} -result [expr { $count+1 }]
@@ -428,6 +435,8 @@ namespace eval ::msgcat::test {
mclocale foo_BAR_notexist
} -cleanup {
mclocale $locale
+ mcloadedlocales clear
+ mcpackageconfig unset mcfolder
} -body {
mcload $msgdir
} -result 3
@@ -437,6 +446,8 @@ namespace eval ::msgcat::test {
mclocale no_FI_notexist
} -cleanup {
mclocale $locale
+ mcloadedlocales clear
+ mcpackageconfig unset mcfolder
} -body {
mcload $msgdir
} -result 1
@@ -497,6 +508,20 @@ namespace eval ::msgcat::test {
mc def
} -result unknown:no_fi_notexist:def
+ test msgcat-5.11 {mcpackageconfig mcfolder} -setup {
+ variable locale [mclocale]
+ mclocale ""
+ mcloadedlocales clear
+ mcpackageconfig unset mcfolder
+ } -cleanup {
+ mclocale $locale
+ mcloadedlocales clear
+ mcpackageconfig unset mcfolder
+ } -body {
+ mclocale foo
+ mcpackageconfig set mcfolder $msgdir
+ } -result 2
+
foreach loc $locales {
if { $loc eq {} } {
set msg ROOT
@@ -657,6 +682,394 @@ namespace eval ::msgcat::test {
removeDirectory msgdir2
removeDirectory msgdir3
+ # Tests msgcat-9.*: [mcexists]
+
+ test msgcat-9.1 {mcexists no parameter} -body {
+ mcexists
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"}
+
+ test msgcat-9.2 {mcexists unknown option} -body {
+ mcexists -unknown src
+ } -returnCodes 1\
+ -result {unknown option "-unknown"}
+
+ test msgcat-9.3 {mcexists} -setup {
+ mcforgetpackage
+ variable locale [mclocale]
+ mclocale foo
+ mcset foo k1 v1
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ list [mcexists k1] [mcexists k2]
+ } -result {1 0}
+
+ test msgcat-9.4 {mcexists descendent preference} -setup {
+ mcforgetpackage
+ variable locale [mclocale]
+ mclocale foo_bar
+ mcset foo k1 v1
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ list [mcexists k1] [mcexists -exactlocale k1]
+ } -result {1 0}
+
+ test msgcat-9.5 {mcexists parent namespace} -setup {
+ mcforgetpackage
+ variable locale [mclocale]
+ mclocale foo_bar
+ mcset foo k1 v1
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ namespace eval ::msgcat::test::sub {
+ list [::msgcat::mcexists k1]\
+ [::msgcat::mcexists -exactnamespace k1]
+ }
+ } -result {1 0}
+
+ # Tests msgcat-10.*: [mcloadedlocales]
+
+ test msgcat-10.1 {mcloadedlocales no arg} -body {
+ mcloadedlocales
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcloadedlocales subcommand"}
+
+ test msgcat-10.2 {mcloadedlocales wrong subcommand} -body {
+ mcloadedlocales junk
+ } -returnCodes 1\
+ -result {unknown subcommand "junk": must be clear, or loaded}
+
+ test msgcat-10.3 {mcloadedlocales loaded} -setup {
+ mcforgetpackage
+ variable locale [mclocale]
+ mclocale {}
+ mcloadedlocales clear
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale foo_bar
+ # The result is position independent so sort
+ set resultlist [lsort [mcloadedlocales loaded]]
+ } -result {{} foo foo_bar}
+
+ test msgcat-10.4 {mcloadedlocales clear} -setup {
+ mcforgetpackage
+ variable locale [mclocale]
+ mclocale {}
+ mcloadedlocales clear
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale foo
+ mcset foo k1 v1
+ set res [mcexists k1]
+ mclocale ""
+ mcloadedlocales clear
+ mclocale foo
+ lappend res [mcexists k1]
+ } -result {1 0}
+
+ # Tests msgcat-11.*: [mcforgetpackage]
+
+ test msgcat-11.1 {mcforgetpackage translation} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale foo
+ mcset foo k1 v1
+ set res [mcexists k1]
+ mcforgetpackage
+ lappend res [mcexists k1]
+ } -result {1 0}
+
+ test msgcat-11.2 {mcforgetpackage locale} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale foo
+ mcpackagelocale set bar
+ set res [mcpackagelocale get]
+ mcforgetpackage
+ lappend res [mcpackagelocale get]
+ } -result {bar foo}
+
+ test msgcat-11.3 {mcforgetpackage options} -body {
+ mcpackageconfig set loadcmd ""
+ set res [mcpackageconfig isset loadcmd]
+ mcforgetpackage
+ lappend res [mcpackageconfig isset loadcmd]
+ } -result {1 0}
+
+ # Tests msgcat-12.*: [mcpackagelocale]
+
+ test msgcat-12.1 {mcpackagelocale no subcommand} -body {
+ mcpackagelocale
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"}
+
+ test msgcat-12.2 {mclpackagelocale wrong subcommand} -body {
+ mcpackagelocale junk
+ } -returnCodes 1\
+ -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset}
+
+ test msgcat-12.3 {mcpackagelocale set} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ mcpackagelocale set bar
+ list [mcpackagelocale get] [mclocale]
+ } -result {bar foo}
+
+ test msgcat-12.4 {mcpackagelocale get} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ set res [mcpackagelocale get]
+ mcpackagelocale set bar
+ lappend res [mcpackagelocale get]
+ } -result {foo bar}
+
+ test msgcat-12.5 {mcpackagelocale preferences} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ set res [list [mcpackagelocale preferences]]
+ mcpackagelocale set bar
+ lappend res [mcpackagelocale preferences]
+ } -result {{foo {}} {bar {}}}
+
+ test msgcat-12.6 {mcpackagelocale loaded} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale ""
+ mcloadedlocales clear
+ mclocale foo
+ # The result is position independent so sort
+ set res [list [lsort [mcpackagelocale loaded]]]
+ mcpackagelocale set bar
+ lappend res [lsort [mcpackagelocale loaded]]
+ } -result {{{} foo} {{} bar foo}}
+
+ test msgcat-12.7 {mcpackagelocale isset} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ set res [mcpackagelocale isset]
+ mcpackagelocale set bar
+ lappend res [mcpackagelocale isset]
+ } -result {0 1}
+
+ test msgcat-12.8 {mcpackagelocale unset} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mcpackagelocale set bar
+ set res [mcpackagelocale isset]
+ mcpackagelocale unset
+ lappend res [mcpackagelocale isset]
+ } -result {1 0}
+
+ test msgcat-12.9 {mcpackagelocale present} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale ""
+ mcloadedlocales clear
+ mclocale foo
+ set res [mcpackagelocale present foo]
+ lappend res [mcpackagelocale present bar]
+ mcpackagelocale set bar
+ lappend res [mcpackagelocale present foo]\
+ [mcpackagelocale present bar]
+ } -result {1 0 1 1}
+
+ test msgcat-12.10 {mcpackagelocale clear} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale ""
+ mcloadedlocales clear
+ mclocale foo
+ mcpackagelocale set bar
+ mcpackagelocale clear
+ list [mcpackagelocale present foo] [mcpackagelocale present bar]
+ } -result {0 1}
+
+ # Tests msgcat-13.*: [mcpackageconfig subcmds]
+
+ test msgcat-13.1 {mcpackageconfig no subcommand} -body {
+ mcpackageconfig
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcpackageconfig subcommand option ?value?"}
+
+ test msgcat-13.2 {mclpackageconfig wrong subcommand} -body {
+ mcpackageconfig junk mcfolder
+ } -returnCodes 1\
+ -result {unknown subcommand "junk": must be get, isset, set, or unset}
+
+ test msgcat-13.3 {mclpackageconfig wrong option} -body {
+ mcpackageconfig get junk
+ } -returnCodes 1\
+ -result {bad option "junk": must be mcfolder, loadcmd, changecmd, or unknowncmd}
+
+ test msgcat-13.4 {mcpackageconfig get} -setup {
+ mcforgetpackage
+ } -cleanup {
+ mcforgetpackage
+ } -body {
+ mcpackageconfig set loadcmd ""
+ mcpackageconfig get loadcmd
+ } -result {}
+
+ test msgcat-13.5 {mcpackageconfig (is/un)set} -setup {
+ mcforgetpackage
+ } -cleanup {
+ mcforgetpackage
+ } -body {
+ set res [mcpackageconfig isset loadcmd]
+ lappend res [mcpackageconfig set loadcmd ""]
+ lappend res [mcpackageconfig isset loadcmd]
+ mcpackageconfig unset loadcmd
+ lappend res [mcpackageconfig isset loadcmd]
+ } -result {0 0 1 0}
+
+ # option mcfolder is already tested with 5.11
+
+ # Tests msgcat-14.*: callbacks: loadcmd, changecmd, unknowncmd
+
+ # This routine is used as bgerror and by direct callback invocation
+ proc callbackproc args {
+ variable resultvariable
+ set resultvariable $args
+ }
+ proc callbackfailproc args {
+ return -code error fail
+ }
+ set bgerrorsaved [interp bgerror {}]
+ interp bgerror {} [namespace code callbackproc]
+
+ test msgcat-14.1 {invokation loadcmd} -setup {
+ mcforgetpackage
+ mclocale $locale
+ mclocale ""
+ mcloadedlocales clear
+ set resultvariable ""
+ } -cleanup {
+ mcforgetpackage
+ } -body {
+ mcpackageconfig set loadcmd [namespace code callbackproc]
+ mclocale foo_bar
+ lsort $resultvariable
+ } -result {foo foo_bar}
+
+ test msgcat-14.2 {invokation failed in loadcmd} -setup {
+ mcforgetpackage
+ mclocale $locale
+ mclocale ""
+ mcloadedlocales clear
+ } -cleanup {
+ mcforgetpackage
+ } -body {
+ mcpackageconfig set loadcmd [namespace code callbackfailproc]
+ mclocale foo_bar
+ # let the bgerror run
+ after 100 set [namespace current]::resultvariable timeout
+ vwait [namespace current]::resultvariable
+ lassign $resultvariable err errdict
+ list $err [dict get $errdict -code]
+ } -result {fail 1}
+
+ test msgcat-14.3 {invokation changecmd} -setup {
+ mcforgetpackage
+ mclocale $locale
+ mclocale ""
+ set resultvariable ""
+ } -cleanup {
+ mcforgetpackage
+ } -body {
+ mcpackageconfig set changecmd [namespace code callbackproc]
+ mclocale foo_bar
+ set resultvariable
+ } -result {foo_bar foo {}}
+
+ test msgcat-14.4 {invokation unknowncmd} -setup {
+ mcforgetpackage
+ mclocale $locale
+ mclocale ""
+ mcloadedlocales clear
+ set resultvariable ""
+ } -cleanup {
+ mcforgetpackage
+ } -body {
+ mcpackageconfig set unknowncmd [namespace code callbackproc]
+ mclocale foo_bar
+ mc k1 p1
+ set resultvariable
+ } -result {foo_bar k1 p1}
+
+ test msgcat-14.5 {disable global unknowncmd} -setup {
+ mcforgetpackage
+ mclocale $locale
+ mclocale ""
+ mcloadedlocales clear
+ set resultvariable ""
+ rename ::msgcat::mcunknown SavedMcunknown
+ proc ::msgcat::mcunknown {dom s} {
+ return unknown:$dom:$s
+ }
+ } -cleanup {
+ mcforgetpackage
+ rename ::msgcat::mcunknown {}
+ rename SavedMcunknown ::msgcat::mcunknown
+ } -body {
+ mcpackageconfig set unknowncmd ""
+ mclocale foo_bar
+ mc k1%s p1
+ } -result {k1p1}
+
+ test msgcat-14.6 {unknowncmd failing} -setup {
+ mcforgetpackage
+ mclocale $locale
+ mclocale ""
+ mcloadedlocales clear
+ set resultvariable ""
+ } -cleanup {
+ mcforgetpackage
+ } -body {
+ mcpackageconfig set unknowncmd [namespace code callbackfailproc]
+ mclocale foo_bar
+ mc k1
+ } -returnCodes 1\
+ -result {fail}
+
+ interp bgerror {} $bgerrorsaved
+
cleanupTests
}
namespace delete ::msgcat::test
diff --git a/tests/namespace.test b/tests/namespace.test
index f6688f1..cded1f4 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -303,7 +303,7 @@ test namespace-9.4 {Tcl_Import, simple import} {
}
test_ns_import::p
} {cmd1: 123}
-test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
+test namespace-9.5 {Tcl_Import, RFE 1230597} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
@@ -558,6 +558,15 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} {
lappend l [info commands ::test_ns_import::*]
}
} {::test_ns_import::cmd1 {}}
+test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} {
+ # Will panic if still buggy
+ namespace eval src {namespace export foo; proc foo {} {}}
+ namespace eval dst {namespace import [namespace parent]::src::foo}
+ trace add command src::foo delete \
+ "[list namespace delete [namespace current]::dst] ;#"
+ proc src::foo {} {}
+ namespace delete src
+} {}
test namespace-14.1 {TclGetNamespaceForQualName, absolute names} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
@@ -2940,6 +2949,10 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \
rename getbytes {}
unset i ns start end
} -result 0
+
+test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} {
+ info class [format %s constructor] oo::object
+} ""
# cleanup
catch {rename cmd1 {}}
diff --git a/tests/nre.test b/tests/nre.test
index b5eb032..e512eac 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -151,6 +151,27 @@ test nre-4.1 {ensembles are not recursive} -setup {
testnrelevels
} -result {{0 2 1 1} 0}
+test nre-4.2 {(compiled) ensembles do not break tailcall} -setup {
+ # Fix Bug d87cb18205
+ proc b {} {
+ tailcall append result first
+ }
+ set map [namespace ensemble configure ::dict -map]
+ dict set map a b
+ namespace ensemble configure ::dict -map $map
+ proc demo {} {
+ dict a
+ append result second
+ }
+} -body {
+ demo
+} -cleanup {
+ rename demo {}
+ namespace ensemble configure ::dict -map [dict remove $map a]
+ unset map
+ rename b {}
+} -result firstsecond
+
test nre-5.1 {[namespace eval] is not recursive} -setup {
namespace eval ::foo {
setabs
diff --git a/tests/obj.test b/tests/obj.test
index 71a39b4..151abfb 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -605,7 +605,7 @@ test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
set x 0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
-test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.3 {integer overflow on input} {
set x 0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
@@ -621,7 +621,7 @@ test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
set x -0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
-test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.7 {integer overflow on input} {
set x -0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}
diff --git a/tests/oo.test b/tests/oo.test
index 37bbadb..c83e015 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::*
@@ -101,7 +101,7 @@ test oo-0.8 {leak in variable management} -setup {
test oo-0.9 {various types of presence of the TclOO package} {
list [lsearch -nocase -all -inline [package names] tcloo] \
[package present TclOO] [package versions TclOO]
-} [list TclOO $::oo::version $::oo::version]
+} [list TclOO $::oo::patchlevel $::oo::patchlevel]
test oo-1.1 {basic test of OO functionality: no classes} {
set result {}
@@ -258,6 +258,29 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
rename test-oo-1.18 {}
A destroy
} -result ::C
+test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
+ proc test-oo-1.18 {} return
+} -constraints memory -body {
+ leaktest {
+ oo::class create A
+ oo::class create B {superclass A}
+ oo::define B constructor {} {A create test-oo-1.18}
+ B create C
+ A destroy
+ }
+} -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]
@@ -270,6 +293,23 @@ test oo-1.20 {basic test of OO functionality: my teardown post rename} -body {
obj destroy
info commands ::AGlobalName
} -result {}
+test oo-1.21 {basic test of OO functionality: default relations} -setup {
+ set fresh [interp create]
+} -body {
+ lmap x [$fresh eval {
+ foreach cmd {instances subclasses mixins superclass} {
+ foreach initial {object class Slot} {
+ lappend x [info class $cmd ::oo::$initial]
+ }
+ }
+ foreach initial {object class Slot} {
+ lappend x [info object class ::oo::$initial]
+ }
+ return $x
+ }] {lsort $x}
+} -cleanup {
+ interp delete $fresh
+} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
test oo-2.1 {basic test of OO functionality: constructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
@@ -376,6 +416,31 @@ test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup {
} -returnCodes error -cleanup {
namespace delete k
} -result {wrong # args: should be "k next j"}
+test oo-2.9 {construction failures and self creation} -setup {
+ set ::result {}
+ oo::class create Root
+} -body {
+ oo::class create A {
+ superclass Root
+ constructor {} {
+ lappend ::result "in A"
+ error "failure in A"
+ }
+ destructor {lappend ::result [self]}
+ }
+ oo::class create B {
+ superclass Root
+ constructor {} {
+ lappend ::result "in B [self]"
+ error "failure in B"
+ }
+ destructor {lappend ::result [self]}
+ }
+ lappend ::result [catch {A create a} msg] $msg
+ lappend ::result [catch {B create b} msg] $msg
+} -cleanup {
+ Root destroy
+} -result {{in A} ::a 1 {failure in A} {in B ::b} ::b 1 {failure in B}}
test oo-3.1 {basic test of OO functionality: destructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as we're
@@ -1504,6 +1569,34 @@ test oo-12.7 {OO: filters} -setup {
} -cleanup {
Aclass destroy
} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}}
+test oo-12.8 {OO: filters and destructors} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+ set ::log {}
+} -body {
+ oo::define Aclass {
+ constructor {} {
+ lappend ::log "in constructor"
+ }
+ destructor {
+ lappend ::log "in destructor"
+ }
+ method bar {} {
+ lappend ::log "in method"
+ }
+ method Boo args {
+ lappend ::log [self target]
+ next {*}$args
+ }
+ filter Boo
+ }
+ set obj [Aclass new]
+ $obj bar
+ $obj destroy
+ return $::log
+} -cleanup {
+ Aclass destroy
+} -result {{in constructor} {::Aclass bar} {in method} {::oo::object destroy} {in destructor}}
test oo-13.1 {OO: changing an object's class} {
oo::class create Aclass
@@ -1984,6 +2077,30 @@ test oo-16.13 {OO: object introspection} -setup {
oo::objdefine foo method Bar {} {return "ok in foo"}
[info object namespace foo]::my Bar
} -result "ok in foo"
+test oo-16.14 {OO: object introspection: TIP #436} -setup {
+ oo::class create meta { superclass oo::class }
+ [meta create instance1] create instance2
+} -body {
+ list class [list [info object isa class NOTANOBJECT] \
+ [info object isa class list]] \
+ meta [list [info object isa metaclass NOTANOBJECT] \
+ [info object isa metaclass list] \
+ [info object isa metaclass oo::object]] \
+ type [list [info object isa typeof oo::object NOTANOBJECT] \
+ [info object isa typeof NOTANOBJECT oo::object] \
+ [info object isa typeof list NOTANOBJECT] \
+ [info object isa typeof NOTANOBJECT list] \
+ [info object isa typeof oo::object list] \
+ [info object isa typeof list oo::object]] \
+ mix [list [info object isa mixin oo::object NOTANOBJECT] \
+ [info object isa mixin NOTANOBJECT oo::object] \
+ [info object isa mixin list NOTANOBJECT] \
+ [info object isa mixin NOTANOBJECT list] \
+ [info object isa mixin oo::object list] \
+ [info object isa mixin list oo::object]]
+} -cleanup {
+ meta destroy
+} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
test oo-17.1 {OO: class introspection} -body {
info class
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index a47aa91..6a48d28 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::*
@@ -526,6 +526,93 @@ test oo-call-1.19 {object call introspection - memory leaks} -setup {
} -cleanup {
leaktester destroy
} -constraints memory -result 0
+test oo-call-1.20 {object call introspection - complex case} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::B {
+ superclass A
+ method x {} {}
+ }
+ oo::class create ::C {
+ superclass root
+ method x {} {}
+ mixin B
+ }
+ oo::class create ::D {
+ superclass C
+ method x {} {}
+ }
+ oo::class create ::E {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::F {
+ superclass E
+ method x {} {}
+ }
+ oo::class create ::G {
+ superclass root
+ method x {} {}
+ }
+ oo::class create ::H {
+ superclass G
+ method x {} {}
+ }
+ oo::define F mixin H
+ F create y
+ oo::objdefine y {
+ method x {} {}
+ mixin D
+ }
+ info object call y x
+} -cleanup {
+ root destroy
+} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}}
+test oo-call-1.21 {object call introspection - complex case} -setup {
+ oo::class create root
+} -body {
+ oo::class create ::A {
+ superclass root
+ method y {} {}
+ filter y
+ }
+ oo::class create ::B {
+ superclass A
+ method y {} {}
+ }
+ oo::class create ::C {
+ superclass root
+ method x {} {}
+ mixin B
+ }
+ oo::class create ::D {
+ superclass C
+ filter x
+ }
+ oo::class create ::E {
+ superclass root
+ method y {} {}
+ method x {} {}
+ }
+ oo::class create ::F {
+ superclass E
+ method z {} {}
+ method q {} {}
+ }
+ F create y
+ oo::objdefine y {
+ method unknown {} {}
+ mixin D
+ filter q
+ }
+ info object call y z
+} -cleanup {
+ root destroy
+} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}}
test oo-call-2.1 {class call introspection} -setup {
oo::class create root
@@ -779,6 +866,196 @@ test oo-call-3.4 {current call introspection: in destructors} -setup {
} -cleanup {
root destroy
} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}
+
+# Contributed tests from aspect, related to [0f42ff7871]
+#
+# dkf's "Principles Leading to a Fix"
+#
+# A method ought to work "the same" whether or not it has been overridden by
+# a subclass. A tailcalled command ought to have as parent stack the same
+# thing you'd get with uplevel 1. A subclass will often expect the
+# superclass's result to be the result that would be returned if the
+# subclass was not there.
+
+# Common setup:
+# any invocation of bar should emit "abc\nhi\n" then return to its
+# caller
+set testopts {
+ -setup {
+ oo::class create Master
+ oo::class create Foo {
+ superclass Master
+ method bar {} {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Master
+ }
+ }
+ -cleanup {
+ Master destroy
+ }
+}
+
+# these succeed, showing that without [next] the bug doesn't fire
+test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body {
+ [Foo create foo] bar
+} -output [join {abc hi} \n]\n
+test next-tailcall-simple-2 "my bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ my bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ [self] bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-simple-4 "foo bar" {*}$testopts -body {
+ oo::define Foo method baz {} {
+ puts a
+ foo bar
+ puts b
+ }
+ [Foo create foo] baz
+} -output [join {a abc hi b} \n]\n
+
+# everything from here on uses [next], and fails on 8.6.4 with compilation
+test next-tailcall-superclass-1 "next superclass" {*}$testopts -body {
+ oo::define Foo2 {
+ superclass Foo
+ method bar {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ [Foo2 create foo] bar
+} -output [join {a abc hi b} \n]\n
+test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body {
+ oo::define Foo2 {
+ superclass Foo
+ method bar {} {
+ puts a
+ nextto Foo
+ puts b
+ }
+ }
+ [Foo2 create foo] bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-mixin-1 "class mixin" {*}$testopts -body {
+ oo::define Foo2 {
+ method Bar {} {
+ puts a
+ next
+ puts b
+ }
+ filter Bar
+ }
+ oo::define Foo mixin Foo2
+ Foo create foo
+ foo bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body {
+ oo::define Foo2 {
+ method Bar {} {
+ puts a
+ next
+ puts b
+ }
+ filter Bar
+ }
+ Foo create foo
+ oo::objdefine foo mixin Foo2
+ foo bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-filter-1 "filter method" {*}$testopts -body {
+ oo::define Foo method Filter {} {
+ puts a
+ next
+ puts b
+ }
+ oo::define Foo filter Filter
+ [Foo new] bar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-forward-1 "forward method" {*}$testopts -body {
+ proc foobar {} {
+ puts "abc"
+ tailcall puts "hi"
+ puts "xyz"
+ }
+ oo::define Foo forward foobar foobar
+ oo::define Foo2 {
+ superclass Foo
+ method foobar {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ [Foo2 new] foobar
+} -output [join {a abc hi b} \n]\n
+
+test next-tailcall-constructor-1 "next in constructor" -body {
+ oo::class create Foo {
+ constructor {} {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Foo
+ constructor {} {
+ puts a
+ next
+ puts b
+ }
+ }
+ list [Foo new] [Foo2 new]
+ return ""
+} -cleanup {
+ Foo destroy
+} -output [join {abc hi a abc hi b} \n]\n
+
+test next-tailcall-destructor-1 "next in destructor" -body {
+ oo::class create Foo {
+ destructor {
+ puts abc
+ tailcall puts hi
+ puts xyz
+ }
+ }
+ oo::class create Foo2 {
+ superclass Foo
+ destructor {
+ puts a
+ next
+ puts b
+ }
+ }
+ Foo create foo
+ Foo2 create foo2
+ foo destroy
+ foo2 destroy
+} -output [join {abc hi a abc hi b} \n]\n -cleanup {
+ Foo destroy
+}
+
+unset testopts
cleanupTests
return
diff --git a/tests/parse.test b/tests/parse.test
index 01443c9..d73c725 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -20,6 +20,7 @@ namespace eval ::tcl::test::parse {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testparser [llength [info commands testparser]]
+testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint testparsevarname [llength [info commands testparsevarname]]
@@ -29,8 +30,8 @@ testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevent [llength [info commands testevent]]
testConstraint memory [llength [info commands memory]]
-test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
- testparser [bytestring "foo\0 bar"] -1
+test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {testparser testbytestring} {
+ testparser [testbytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser "foo bar" -1
@@ -301,9 +302,11 @@ test parse-6.15 {ParseTokens procedure, backslash-newline} testparser {
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 {
- testparser [bytestring "foo\0zz"] 0
-} "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}"
+test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} {
+ 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
@@ -660,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
@@ -700,8 +706,8 @@ test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup {
rename getbytes {}
} -result 0
-test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser {
- testparser [bytestring "foo\0 bar"] -1
+test parse-14.1 {Tcl_ParseBraces procedure, computing string length} {testparser testbytestring} {
+ testparser [testbytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser {
testparser "foo bar" -1
@@ -737,8 +743,8 @@ test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser {
list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $::errorInfo
} {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"}
-test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} testparser {
- testparser [bytestring "foo\0 bar"] -1
+test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {testparser testbytestring} {
+ testparser [testbytestring "foo\0 bar"] -1
} {- foo 1 simple foo 1 text foo 0 {}}
test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser {
testparser "foo bar" -1
@@ -903,11 +909,11 @@ test parse-15.53 {CommandComplete procedure} "
test parse-15.54 {CommandComplete procedure} "
info complete \"foo bar;# \{\"
" 1
-test parse-15.55 {CommandComplete procedure} {
- info complete "set x [bytestring \0]; puts hi"
+test parse-15.55 {CommandComplete procedure} testbytestring {
+ info complete "set x [testbytestring \0]; puts hi"
} 1
-test parse-15.56 {CommandComplete procedure} {
- info complete "set x [bytestring \0]; \{"
+test parse-15.56 {CommandComplete procedure} testbytestring {
+ info complete "set x [testbytestring \0]; \{"
} 0
test parse-15.57 {CommandComplete procedure} {
info complete "# Comment should be complete command"
@@ -915,9 +921,9 @@ 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 [encoding convertfrom identity "\x00;if 1 \{"]
+ info complete [testbytestring "\x00;if 1 \{"]
} 0
test parse-15.60 {CommandComplete procedure} {
# Test for Tcl Bug 1968882
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 714c45b..ef05454 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -20,6 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
# of "<<" are integers.
testConstraint testexprparser [llength [info commands testexprparser]]
+testConstraint testbytestring [llength [info commands testbytestring]]
# Big test for correct ordering of data in [expr]
@@ -81,8 +82,8 @@ testConstraint ieeeFloatingPoint [testIEEE]
######################################################################
-test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser {
- testexprparser [bytestring "1+2\0 +3"] -1
+test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {testexprparser testbytestring} {
+ testexprparser [testbytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser {
testexprparser "1 + 2" -1
@@ -1063,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 f3b1591..a6e07a2b 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -20,6 +20,7 @@ namespace import ::tcltest::*
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwordend [llength [info commands testwordend]]
+testConstraint testbytestring [llength [info commands testbytestring]]
# Save the argv value for restoration later
set savedArgv $argv
@@ -261,15 +262,15 @@ test parseOld-7.10 {backslash substitution} {
test parseOld-7.11 {backslash substitution} {
eval "list a \"b c\"\\\nd e"
} {a {b c} d e}
-test parseOld-7.12 {backslash substitution} {
- list \ua2
-} [bytestring "\xc2\xa2"]
-test parseOld-7.13 {backslash substitution} {
- list \u4e21
-} [bytestring "\xe4\xb8\xa1"]
-test parseOld-7.14 {backslash substitution} {
- list \u4e2k
-} [bytestring "\xd3\xa2k"]
+test parseOld-7.12 {backslash substitution} testbytestring {
+ expr {[list \ua2] eq [testbytestring "\xc2\xa2"]}
+} 1
+test parseOld-7.13 {backslash substitution} testbytestring {
+ expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]}
+} 1
+test parseOld-7.14 {backslash substitution} testbytestring {
+ expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]}
+} 1
# Semi-colon.
diff --git a/tests/regexp.test b/tests/regexp.test
index 1b2bec9..a83c99b 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -241,13 +241,13 @@ test regexp-5.5 {exercise cache of compiled expressions} {
test regexp-6.1 {regexp errors} {
list [catch {regexp a} msg] $msg
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
+} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.2 {regexp errors} {
list [catch {regexp -nocase a} msg] $msg
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
+} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexp-6.3 {regexp errors} {
list [catch {regexp -gorp a} msg] $msg
-} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexp-6.4 {regexp errors} {
list [catch {regexp a( b} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
@@ -441,19 +441,19 @@ test regexp-10.5 {inverse partial newline sensitivity in regsub} {
test regexp-11.1 {regsub errors} {
list [catch {regsub a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.2 {regsub errors} {
list [catch {regsub -nocase a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.3 {regsub errors} {
list [catch {regsub -nocase -all a b} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} {
list [catch {regsub a b c d e f} msg] $msg
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
list [catch {regsub -gorp a b c} msg] $msg
-} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexp-11.6 {regsub errors} {
list [catch {regsub -nocase a( b c d} msg] $msg
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
diff --git a/tests/regexpComp.test b/tests/regexpComp.test
index 94fb90e..01ef06d 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -316,17 +316,17 @@ test regexpComp-6.1 {regexp errors} {
evalInProc {
list [catch {regexp a} msg] $msg
}
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
+} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.2 {regexp errors} {
evalInProc {
list [catch {regexp -nocase a} msg] $msg
}
-} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}}
+} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}}
test regexpComp-6.3 {regexp errors} {
evalInProc {
list [catch {regexp -gorp a} msg] $msg
}
-} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
@@ -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 {
@@ -562,27 +567,27 @@ test regexpComp-11.1 {regsub errors} {
evalInProc {
list [catch {regsub a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.2 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.3 {regsub errors} {
evalInProc {
list [catch {regsub -nocase -all a b} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.4 {regsub errors} {
evalInProc {
list [catch {regsub a b c d e f} msg] $msg
}
-} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}}
+} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}}
test regexpComp-11.5 {regsub errors} {
evalInProc {
list [catch {regsub -gorp a b c} msg] $msg
}
-} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
+} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
diff --git a/tests/registry.test b/tests/registry.test
index 77588e3..0f78212 100644
--- a/tests/registry.test
+++ b/tests/registry.test
@@ -19,7 +19,7 @@ testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
- set ::regver [package require registry 1.3.0]
+ set ::regver [package require registry 1.3.1]
}]} {
testConstraint reg 1
}
@@ -33,7 +33,7 @@ testConstraint english [expr {
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
-} {1.3.0}
+} {1.3.1}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
diff --git a/tests/scan.test b/tests/scan.test
index ea0c500..b57b641 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -375,6 +375,12 @@ test scan-4.48 {Tcl_ScanObjCmd, float scanning} {
test scan-4.49 {Tcl_ScanObjCmd, float scanning} {
list [scan {.1 0.2 3.} {%e %f %g} x y z] $x $y $z
} {3 0.1 0.2 3.0}
+test scan-4.49-uc-1 {Tcl_ScanObjCmd, float scanning} {
+ list [scan {0.5*0.75} {%E%c%G} x y z] $x $y $z
+} {3 0.5 42 0.75}
+test scan-4.49-uc-2 {Tcl_ScanObjCmd, float scanning} {
+ list [scan {5e-1*75E-2} {%E%c%G} x y z] $x $y $z
+} {3 0.5 42 0.75}
test scan-4.50 {Tcl_ScanObjCmd, float scanning} {
list [scan {1234567890a} %f x] $x
} {1 1234567890.0}
@@ -450,6 +456,9 @@ test scan-4.63 {scanning of large and negative hex integers} {
list [scan $scanstring {%x %x %x} a b c] \
[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
+test scan-4.64 {scanning of hex with %X} {
+ scan "123 abc f78" %X%X%X
+} {291 2748 3960}
test scan-5.1 {integer scanning} -setup {
set a {}; set b {}; set c {}; set d {}
@@ -626,14 +635,14 @@ test scan-8.4 {error conditions} -returnCodes error -body {
scan a %O x
} -result {bad scan conversion character "O"}
test scan-8.5 {error conditions} -returnCodes error -body {
- scan a %X x
-} -result {bad scan conversion character "X"}
+ scan a %B x
+} -result {bad scan conversion character "B"}
test scan-8.6 {error conditions} -returnCodes error -body {
scan a %F x
} -result {bad scan conversion character "F"}
test scan-8.7 {error conditions} -returnCodes error -body {
- scan a %E x
-} -result {bad scan conversion character "E"}
+ scan a %p x
+} -result {bad scan conversion character "p"}
test scan-8.8 {error conditions} -returnCodes error -body {
scan a "%d %d" a
} -result {different numbers of variable names and field specifiers}
diff --git a/tests/set-old.test b/tests/set-old.test
index 4c25ec5..94b6901 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -305,6 +305,11 @@ test set-old-7.18 {unset command, -nocomplain (no abbreviation)} {
catch {unset -nocomp}
list [info exists -nocomp] [catch {unset -nocomp}]
} {0 1}
+test set-old-7.19 {unset command, both switches} {
+ set -- val
+ list [info exists --] [catch {unset -nocomplain --}] [info exists --]\
+ [catch {unset -nocomplain -- --}] [info exists --]
+} {1 0 1 0 0}
# Array command.
diff --git a/tests/socket.test b/tests/socket.test
index 5542c09..4f90e51 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -86,8 +86,21 @@ puts $s2 test1; gets $s1
puts $s2 test2; gets $s1
close $s1; close $s2
set t2 [clock milliseconds]
-set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin
-unset t1 t2 s1 s2 server
+set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin
+
+# Test the latency of failed connection attempts over the loopback
+# interface. They can take more than a second under Windowos and requres
+# additional [after]s in some tests that are not needed on systems that fail
+# immediately.
+set t1 [clock milliseconds]
+catch {socket 127.0.0.1 [randport]}
+set t2 [clock milliseconds]
+set lat2 [expr {($t2-$t1)*3}]
+
+# Use the maximum of the two latency calculations, but at least 100ms
+set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}]
+set latency [expr {$latency > 100 ? $latency : 1000}]
+unset t1 t2 s1 s2 lat1 lat2 server
# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
@@ -124,7 +137,6 @@ foreach {af localhost} {
testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}]
catch {close $sock}
}
-testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}]
set sock [socket -server foo -myaddr localhost 0]
set sockname [fconfigure $sock -sockname]
@@ -138,6 +150,9 @@ foreach {af localhost} {
inet 127.0.0.1
inet6 ::1
} {
+ if {![testConstraint supported_$af]} {
+ continue
+ }
set ::tcl::unsupported::socketAF $af
#
# Check if we're supposed to do tests against the remote server
@@ -625,6 +640,86 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a
close $s
close $sock
} -result {a:one b: c:two}
+test socket_$af-2.12 {} [list socket stdio supported_$af] {
+ file delete $path(script)
+ set f [open $path(script) w]
+ puts $f {
+ set server [socket -server accept_client 0]
+ puts [lindex [chan configure $server -sockname] 2]
+ proc accept_client { client host port } {
+ chan configure $client -blocking 0 -buffering line
+ write_line $client
+ }
+ proc write_line client {
+ if { [catch { chan puts $client [string repeat . 720000]}] } {
+ puts [catch {chan close $client}]
+ } else {
+ puts signal1
+ after 0 write_line $client
+ }
+ }
+ chan event stdin readable {set forever now}
+ vwait forever
+ exit
+ }
+ close $f
+ set f [open "|[list [interpreter] $path(script)]" r+]
+ gets $f port
+ set sock [socket $localhost $port]
+ chan event $sock readable [list read_lines $sock $f]
+ proc read_lines { sock pipe } {
+ gets $pipe
+ chan close $sock
+ chan event $pipe readable [list readpipe $pipe]
+ }
+ proc readpipe {pipe} {
+ while {![string is integer [set ::done [gets $pipe]]]} {}
+ }
+ vwait ::done
+ close $f
+ set ::done
+} 0
+test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} {
+ file delete $path(script)
+ set f [open $path(script) w]
+ puts $f {
+ set server [socket -server accept 0]
+ puts [lindex [chan configure $server -sockname] 2]
+ proc accept { client host port } {
+ chan configure $client -blocking 0 -buffering line -buffersize 1
+ puts $client [string repeat . 720000]
+ puts ready
+ chan event $client writable [list setup $client]
+ }
+ proc setup client {
+ chan event $client writable {set forever write}
+ after 5 {set forever timeout}
+ }
+ vwait forever
+ puts $forever
+ }
+ close $f
+ set pipe [open |[list [interpreter] $path(script)] r]
+ gets $pipe port
+ set sock [socket $localhost $port]
+ chan configure $sock -blocking 0 -buffering line
+ chan event $sock readable [list read_lines $sock $pipe ]
+ proc read_lines { sock pipe } {
+ gets $pipe
+ gets $sock line
+ after idle [list stop $sock $pipe]
+ chan event $sock readable {}
+ }
+ proc stop {sock pipe} {
+ variable done
+ close $sock
+ set done [gets $pipe]
+ }
+ variable done
+ vwait [namespace which -variable done]
+ close $pipe
+ set done
+} write
test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup {
file delete $path(script)
@@ -1560,8 +1655,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup {
close $f
# If the socket doesn't hit end-of-file in 10 seconds, the script1 process
# must have inherited the client.
- set failed 0
- set after [after 10000 [list set failed 1]]
+ set timeout 0
+ set after [after 10000 {set x "client socket was inherited"}]
} -constraints [list socket supported_$af stdio exec] -body {
# Create the server socket
set server [socket -server accept -myaddr $localhost 0]
@@ -1571,26 +1666,20 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup {
close $server
fileevent $file readable [list getdata $file]
fconfigure $file -buffering line -blocking 0
+ set ::f $file
}
proc getdata { file } {
# Read handler on the accepted socket.
- global x failed
+ global x
set status [catch {read $file} data]
if {$status != 0} {
- set x {read failed, error was $data}
- catch { close $file }
+ set x "read failed, error was $data"
} elseif {$data ne ""} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
- if {$failed} {
- set x {client socket was inherited}
- } else {
- set x {client socket was not inherited}
- }
- catch { close $file }
+ set x "client socket was not inherited"
} else {
- set x {impossible case}
- catch { close $file }
+ set x "impossible case"
}
}
# Launch the script2 process
@@ -1600,6 +1689,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup {
vwait x
return $x
} -cleanup {
+ fconfigure $f -blocking 1
+ close $f
after cancel $after
close $p
} -result {client socket was not inherited}
@@ -1641,35 +1732,30 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
# If the socket is still open after 5 seconds, the script1 process must
# have inherited the accepted socket.
set failed 0
- set after [after 5000 [list set failed 1]]
+ set after [after 5000 [list set x "accepted socket was inherited"]]
proc getdata { file } {
# Read handler on the client socket.
global x
global failed
set status [catch {read $file} data]
if {$status != 0} {
- set x {read failed, error was $data}
- catch { close $file }
+ set x "read failed, error was $data"
} elseif {[string compare {} $data]} {
} elseif {[fblocked $file]} {
} elseif {[eof $file]} {
- if {$failed} {
- set x {accepted socket was inherited}
- } else {
- set x {accepted socket was not inherited}
- }
- catch { close $file }
+ set x "accepted socket was not inherited"
} else {
- set x {impossible case}
- catch { close $file }
+ set x "impossible case"
}
return
}
vwait x
- return $x
+ set x
} -cleanup {
+ fconfigure $f -blocking 1
+ close $f
after cancel $after
- catch {close $p}
+ close $p
} -result {accepted socket was not inherited}
test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
@@ -1723,8 +1809,8 @@ catch {close $commandSocket}
catch {close $remoteProcChan}
}
unset ::tcl::unsupported::socketAF
-test socket-14.0 {[socket -async] when server only listens on IPv4} \
- -constraints [list socket supported_any localhost_v4] \
+test socket-14.0.0 {[socket -async] when server only listens on IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
-setup {
proc accept {s a p} {
global x
@@ -1736,7 +1822,29 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \
set port [lindex [fconfigure $server -sockname] 2]
} -body {
set client [socket -async localhost $port]
- set after [after 1000 {set x [fconfigure $client -error]}]
+ set after [after $latency {set x [fconfigure $client -error]}]
+ vwait x
+ set x
+ } -cleanup {
+ after cancel $after
+ close $server
+ close $client
+ unset x
+ } -result ok
+test socket-14.0.1 {[socket -async] when server only listens on IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr ::1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ } -body {
+ set client [socket -async localhost $port]
+ set after [after $latency {set x [fconfigure $client -error]}]
vwait x
set x
} -cleanup {
@@ -1746,7 +1854,7 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \
unset x
} -result ok
test socket-14.1 {[socket -async] fileevent while still connecting} \
- -constraints [list socket supported_any] \
+ -constraints {socket} \
-setup {
proc accept {s a p} {
global x
@@ -1763,7 +1871,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
lappend x [fconfigure $client -error]
fileevent $client writable {}
}
- set after [after 1000 {lappend x timeout}]
+ set after [after $latency {lappend x timeout}]
while {[llength $x] < 2 && "timeout" ni $x} {
vwait x
}
@@ -1775,26 +1883,21 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
unset x
} -result {{} ok}
test socket-14.2 {[socket -async] fileevent connection refused} \
- -constraints [list socket supported_any] \
+ -constraints {socket} \
-body {
- if {[catch {socket -async localhost [randport]} client]} {
- regexp {[^:]*: (.*)} $client -> x
- } else {
- fileevent $client writable {set x [fconfigure $client -error]}
- set after [after 1000 {set x timeout}]
- vwait x
- after cancel $after
- if {$x eq "timeout"} {
- append x ": [fconfigure $client -error]"
- }
- close $client
- }
- set x
+ set client [socket -async localhost [randport]]
+ fileevent $client writable {set x ok}
+ set after [after $latency {set x timeout}]
+ vwait x
+ after cancel $after
+ lappend x [fconfigure $client -error]
} -cleanup {
- unset x
- } -result "connection refused"
+ after cancel $after
+ close $client
+ unset x after client
+ } -result {ok {connection refused}}
test socket-14.3 {[socket -async] when server only listens on IPv6} \
- -constraints [list socket supported_any localhost_v6] \
+ -constraints {socket supported_inet6 localhost_v6} \
-setup {
proc accept {s a p} {
global x
@@ -1806,7 +1909,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \
set port [lindex [fconfigure $server -sockname] 2]
} -body {
set client [socket -async localhost $port]
- set after [after 1000 {set x [fconfigure $client -error]}]
+ set after [after $latency {set x [fconfigure $client -error]}]
vwait x
set x
} -cleanup {
@@ -1816,7 +1919,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \
unset x
} -result ok
test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
- -constraints [list socket supported_any] \
+ -constraints {socket} \
-setup {
proc accept {s a p} {
puts $s bye
@@ -1832,7 +1935,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
fileevent $client writable {}
}
fileevent $client readable {lappend x [gets $client]}
- set after [after 1000 {lappend x timeout}]
+ set after [after $latency {lappend x timeout}]
while {[llength $x] < 2 && "timeout" ni $x} {
vwait x
}
@@ -1841,15 +1944,466 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
after cancel $after
close $client
close $server
+ unset x
} -result {{} bye}
+# FIXME: we should also have an IPv6 counterpart of this
test socket-14.5 {[socket -async] which fails before any connect() can be made} \
- -constraints [list socket supported_any] \
+ -constraints {socket supported_inet} \
-body {
# address from rfc5737
socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
} \
-returnCodes 1 \
-result {couldn't open socket: cannot assign requested address}
+test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ set x ""
+ } \
+ -body {
+ set client [socket -async localhost $port]
+ for {set i 0} {$i < 50} {incr i } {
+ update
+ if {$x ne ""} {
+ lappend x [gets $client]
+ break
+ }
+ after 100
+ }
+ set x
+ } \
+ -cleanup {
+ close $server
+ close $client
+ unset x
+ } \
+ -result {ok bye}
+test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ proc accept {s a p} {
+ global x
+ puts $s bye
+ close $s
+ set x ok
+ }
+ set server [socket -server accept -myaddr ::1 0]
+ set port [lindex [fconfigure $server -sockname] 2]
+ set x ""
+ } \
+ -body {
+ set client [socket -async localhost $port]
+ for {set i 0} {$i < 50} {incr i } {
+ update
+ if {$x ne ""} {
+ lappend x [gets $client]
+ break
+ }
+ after 100
+ }
+ set x
+ } \
+ -cleanup {
+ close $server
+ close $client
+ unset x
+ } \
+ -result {ok bye}
+test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok {}}
+test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok {}}
+test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ catch {gets $sock} x
+ list $x [fconfigure $sock -error] [fconfigure $sock -error]
+ } -cleanup {
+ close $sock
+ } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
+test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {ok}
+test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {puts $s ok; close $s; set ::x 1}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {ok}
+test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ fconfigure $sock -blocking 0
+ for {set i 0} {$i < 50} {incr i } {
+ if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break
+ after 200
+ }
+ list $x [fconfigure $sock -error] [fconfigure $sock -error]
+ } -cleanup {
+ close $sock
+ } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}}
+test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ puts $sock ok
+ flush $sock
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok}
+test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ puts $sock ok
+ flush $sock
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok}
+test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \
+ -constraints {socket supported_inet localhost_v4} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr 127.0.0.1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ fileevent $fd readable {set x 1}
+ vwait x
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok}
+test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \
+ -constraints {socket supported_inet6 localhost_v6} \
+ -setup {
+ makeFile {
+ fileevent stdin readable exit
+ set server [socket -server accept -myaddr ::1 0]
+ proc accept {s h p} {set ::x $s}
+ puts [lindex [fconfigure $server -sockname] 2]
+ flush stdout
+ vwait x
+ puts [gets $x]
+ } script
+ set fd [open |[list [interpreter] script] RDWR]
+ set port [gets $fd]
+ } -body {
+ set sock [socket -async localhost $port]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ fileevent $fd readable {set x 1}
+ vwait x
+ list [fconfigure $sock -error] [gets $fd]
+ } -cleanup {
+ close $fd
+ close $sock
+ removeFile script
+ } -result {{} ok}
+test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \
+ -constraints {socket} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ fileevent $sock writable {set x 1}
+ vwait x
+ close $sock
+ } -cleanup {
+ catch {close $sock}
+ 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 nonportable} \
+ -body {
+ set sock [socket -async localhost [randport]]
+ fconfigure $sock -blocking 0
+ puts $sock ok
+ flush $sock
+ fileevent $sock writable {set x 1}
+ vwait x
+ close $sock
+ } -cleanup {
+ catch {close $sock}
+ catch {unset x}
+ } -result {socket is not connected} -returnCodes 1
+test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \
+ -constraints {socket} \
+ -body {
+ set s [socket -async localhost [randport]]
+ for {set i 0} {$i < 50} {incr i} {
+ set x [fconfigure $s -error]
+ if {$x != ""} break
+ after 200
+ }
+ set x
+ } -cleanup {
+ close $s
+ unset x s
+ } -result {connection refused}
+
+test socket-14.13 {testing writable event when quick failure} \
+ -constraints {socket win supported_inet} \
+ -body {
+ # Test for bug 336441ed59 where a quick background fail was ignored
+
+ # Test only for windows as socket -async 255.255.255.255 fails
+ # directly on unix
+
+ # The following connect should fail very quickly
+ set a1 [after 2000 {set x timeout}]
+ set s [socket -async 255.255.255.255 43434]
+ fileevent $s writable {set x writable}
+ vwait x
+ set x
+} -cleanup {
+ catch {close $s}
+ after cancel $a1
+} -result writable
+
+test socket-14.14 {testing fileevent readable on failed async socket connect} \
+ -constraints {socket} -body {
+ # Test for bug 581937ab1e
+
+ set a1 [after 5000 {set x timeout}]
+ # This connect should fail
+ set s [socket -async localhost [randport]]
+ fileevent $s readable {set x readable}
+ vwait x
+ set x
+} -cleanup {
+ catch {close $s}
+ after cancel $a1
+} -result readable
+
+test socket-14.15 {blocking read on async socket should not trigger event handlers} \
+ -constraints socket -body {
+ set s [socket -async localhost [randport]]
+ set x ok
+ fileevent $s writable {set x fail}
+ catch {read $s}
+ close $s
+ 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 {}
+
+# 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}}
+set resultok {-result "sock*" -match glob}
+set resulterr {
+ -result {couldn't open socket: connection refused}
+ -returnCodes 1
+}
+foreach {servip sc} $x {
+ foreach {cliip cc} $x {
+ set constraints socket
+ lappend constraints $sc $cc
+ set result $resulterr
+ switch -- [lsort -unique [list $servip $cliip]] {
+ localhost - 127.0.0.1 - ::1 {
+ set result $resultok
+ }
+ {127.0.0.1 localhost} {
+ if {[testConstraint localhost_v4]} {
+ set result $resultok
+ }
+ }
+ {::1 localhost} {
+ if {[testConstraint localhost_v6]} {
+ set result $resultok
+ }
+ }
+ }
+ test socket-15.1.$num "Connect to $servip from $cliip" \
+ -constraints $constraints -setup {
+ set server [socket -server accept -myaddr $servip 0]
+ proc accept {s h p} { close $s }
+ set port [lindex [fconfigure $server -sockname] 2]
+ } -body {
+ set s [socket $cliip $port]
+ } -cleanup {
+ close $server
+ catch {close $s}
+ } {*}$result
+ incr num
+ }
+}
+
::tcltest::cleanupTests
flush stdout
return
diff --git a/tests/source.test b/tests/source.test
index d71212d..0235bd1 100644
--- a/tests/source.test
+++ b/tests/source.test
@@ -187,6 +187,16 @@ test source-3.5 {return with special code etc.} -setup {
invoked from within
"source $sourcefile"} {a b c}}
+test source-4.1 {continuation line parsing} -setup {
+ set sourcefile [makeFile [string map {CL \\\n} {
+ format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]"
+ }] source.file]
+} -body {
+ source $sourcefile
+} -cleanup {
+ removeFile source.file
+} -result {source: 3 4 5}
+
test source-6.1 {source is binary ok} -setup {
# Note [makeFile] writes in the system encoding.
# [source] defaults to reading in the system encoding.
diff --git a/tests/string.test b/tests/string.test
index 740cdc6..3611753 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -30,7 +30,7 @@ testConstraint memory [llength [info commands memory]]
test string-1.1 {error conditions} {
list [catch {string gorp a b} msg] $msg
-} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
list [catch {string} msg] $msg
} {1 {wrong # args: should be "string subcommand ?arg ...?"}}
@@ -54,7 +54,7 @@ test string-2.6 {string compare} {
string compare abcde abdef
} -1
test string-2.7 {string compare, shortest method name} {
- string c abcde ABCDE
+ string co abcde ABCDE
} 1
test string-2.8 {string compare} {
string compare abcde abcde
@@ -81,7 +81,7 @@ test string-2.13 {string compare -nocase} {
string compare -nocase abcde abdef
} -1
test string-2.14 {string compare -nocase} {
- string c -nocase abcde ABCDE
+ string compare -nocase abcde ABCDE
} 0
test string-2.15 {string compare -nocase} {
string compare -nocase abcde abcde
@@ -1398,6 +1398,9 @@ test string-15.9 {string tolower} {
test string-15.10 {string tolower, unicode} {
string tolower ABCabc\xc7\xe7
} "abcabc\xe7\xe7"
+test string-15.11 {string tolower, compiled} {
+ lindex [string tolower [list A B [list C]]] 1
+} b
test string-16.1 {string toupper} {
list [catch {string toupper} msg] $msg
@@ -1429,6 +1432,9 @@ test string-16.9 {string toupper} {
test string-16.10 {string toupper, unicode} {
string toupper ABCabc\xc7\xe7
} "ABCABC\xc7\xc7"
+test string-16.11 {string toupper, compiled} {
+ lindex [string toupper [list a b [list c]]] 1
+} B
test string-17.1 {string totitle} {
list [catch {string totitle} msg] $msg
@@ -1451,6 +1457,9 @@ test string-17.6 {string totitle, unicode} {
test string-17.7 {string totitle, unicode} {
string totitle \u01f3BCabc\xc7\xe7
} "\u01f2bcabc\xe7\xe7"
+test string-17.8 {string totitle, compiled} {
+ lindex [string totitle [list aa bb [list cc]]] 0
+} Aa
test string-18.1 {string trim} {
list [catch {string trim} msg] $msg
@@ -1504,7 +1513,7 @@ test string-20.1 {string trimright errors} {
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2 {string trimright errors} {
list [catch {string trimg a} msg] $msg
-} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-20.3 {string trimright} {
string trimright " XYZ "
} { XYZ}
@@ -1563,7 +1572,7 @@ test string-21.14 {string wordend, unicode} {
test string-22.1 {string wordstart} {
list [catch {string word a} msg] $msg
-} {1 {unknown or ambiguous subcommand "word": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2 {string wordstart} {
list [catch {string wordstart a} msg] $msg
} {1 {wrong # args: should be "string wordstart string index"}}
@@ -1792,8 +1801,8 @@ test string-26.7 {tcl::prefix} -body {
tcl::prefix match -exact {apa bepa cepa depa} be
} -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa}
test string-26.8 {tcl::prefix} -body {
- tcl::prefix match -message switch {apa bepa bear depa} be
-} -returnCodes 1 -result {ambiguous switch "be": must be apa, bepa, bear, or depa}
+ tcl::prefix match -message wombat {apa bepa bear depa} be
+} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa}
test string-26.9 {tcl::prefix} -body {
tcl::prefix match -error {} {apa bepa bear depa} be
} -returnCodes 0 -result {}
@@ -1960,6 +1969,30 @@ test string-28.13 {tcl::prefix longest} {
tcl::prefix longest {ax\x90 bep ax\x91} a
} ax
+test string-29.1 {string cat, no arg} {
+ string cat
+} ""
+test string-29.2 {string cat, single arg} {
+ set x FOO
+ string compare $x [string cat $x]
+} 0
+test string-29.3 {string cat, two args} {
+ set x FOO
+ string compare $x$x [string cat $x $x]
+} 0
+test string-29.4 {string cat, many args} {
+ set x FOO
+ set n 260
+ set xx [string repeat $x $n]
+ set vv [string repeat {$x} $n]
+ set vvs [string repeat {$x } $n]
+ set r1 [string compare $xx [subst $vv]]
+ set r2 [string compare $xx [eval "string cat $vvs"]]
+ list $r1 $r2
+} {0 0}
+
+
+
# cleanup
rename MemStress {}
catch {rename foo {}}
diff --git a/tests/stringComp.test b/tests/stringComp.test
index 9e00ce7..a66525e 100644
--- a/tests/stringComp.test
+++ b/tests/stringComp.test
@@ -26,11 +26,27 @@ catch [list package require -exact Tcltest [info patchlevel]]
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] != {}}]
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc getbytes {} {
+ set lines [split [memory info] \n]
+ return [lindex $lines 3 3]
+ }
+ proc leaktest {script {iterations 3}} {
+ set end [getbytes]
+ for {set i 0} {$i < $iterations} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [getbytes]
+ }
+ return [expr {$end - $tmp}]
+ }
+}
test stringComp-1.1 {error conditions} {
proc foo {} {string gorp a b}
list [catch {foo} msg] $msg
-} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
+} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test stringComp-1.2 {error conditions} {
proc foo {} {string}
list [catch {foo} msg] $msg
@@ -194,7 +210,7 @@ foreach {tname tbody tresult tcode} {
# need a few extra tests short abbr cmd
test stringComp-3.1 {string compare, shortest method name} {
- proc foo {} {string c abcde ABCDE}
+ proc foo {} {string co abcde ABCDE}
foo
} 1
test stringComp-3.2 {string equal, shortest method name} {
@@ -687,7 +703,31 @@ test stringComp-12.1 {Bug 3588366: end-offsets before start} {
## not yet bc
## string replace
-## not yet bc
+test stringComp-14.1 {Bug 82e7f67325} {
+ apply {x {
+ set a [join $x {}]
+ lappend b [string length [string replace ___! 0 2 $a]]
+ lappend b [string length [string replace ___! 0 2 $a[unset a]]]
+ }} {a b}
+} {3 3}
+test stringComp-14.2 {Bug 82e7f67325} memory {
+ # As in stringComp-14.1, but make sure we don't retain too many refs
+ leaktest {
+ apply {x {
+ set a [join $x {}]
+ lappend b [string length [string replace ___! 0 2 $a]]
+ lappend b [string length [string replace ___! 0 2 $a[unset a]]]
+ }} {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
@@ -703,6 +743,40 @@ test stringComp-12.1 {Bug 3588366: end-offsets before start} {
## string word*
## not yet bc
+
+## string cat
+test stringComp-29.1 {string cat, no arg} {
+ proc foo {} {string cat}
+ foo
+} ""
+test stringComp-29.2 {string cat, single arg} {
+ proc foo {} {
+ set x FOO
+ string compare $x [string cat $x]
+ }
+ foo
+} 0
+test stringComp-29.3 {string cat, two args} {
+ proc foo {} {
+ set x FOO
+ string compare $x$x [string cat $x $x]
+ }
+ foo
+} 0
+test stringComp-29.4 {string cat, many args} {
+ proc foo {} {
+ set x FOO
+ set n 260
+ set xx [string repeat $x $n]
+ set vv [string repeat {$x} $n]
+ set vvs [string repeat {$x } $n]
+ set r1 [string compare $xx [subst $vv]]
+ set r2 [string compare $xx [eval "string cat $vvs"]]
+ list $r1 $r2
+ }
+ foo
+} {0 0}
+
# cleanup
catch {rename foo {}}
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 6f331d3..8209142 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -21,6 +21,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
+testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
test stringObj-1.1 {string type registration} testobj {
@@ -338,7 +339,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr
# Because this test does not use \uXXXX notation below instead of
# hardcoding the values, it may fail in multibyte locales. However, we
# need to test that the parser produces untyped objects even when there
- # are high-ASCII characters in the input (like "ï"). I don't know what
+ # are high-ASCII characters in the input (like "ï"). I don't know what
# else to do but inline those characters here.
testdstring free
testdstring append "abc\u00ef\u00efdef" -1
@@ -347,7 +348,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr
[testobj objtype $x] [testobj objtype $y]
} [list none "bc\u00EF\u00EFde" string string]
test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj {
- # set x "abcïïdef"
+ # set x "abcïïdef"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set x "abc\u00EF\u00EFdef"
@@ -356,7 +357,7 @@ test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj {
[testobj objtype $x] [testobj objtype $y]
} [list string "bc\u00EF\u00EFde" string string]
test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj {
- # set a "ïa¿b®cï¿d®"
+ # set a "ïa¿b®cï¿d®"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
@@ -416,24 +417,24 @@ test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj {
string length "\u00ae"
} 1
test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj {
- # string length "○○"
+ # string length "○○"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE"
} 6
test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj {
- # set a "ïa¿b®cï¿d®"
+ # set a "ïa¿b®cï¿d®"
# Use \uXXXX notation below instead of hardcoding the values, otherwise
# the test will fail in multibyte locales.
set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE"
list [string length $a] [string length $a]
} {10 10}
-test stringObj-13.7 {Tcl_GetCharLength with identity nulls} testobj {
+test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
# SF bug #684699
- string length [encoding convertfrom identity \x00]
+ string length [testbytestring \x00]
} 1
-test stringObj-13.8 {Tcl_GetCharLength with identity nulls} testobj {
- string length [encoding convertfrom identity \x01\x00\x02]
+test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
+ string length [testbytestring \x01\x00\x02]
} 3
test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj {
diff --git a/tests/subst.test b/tests/subst.test
index 7466895..2115772 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -15,13 +15,17 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
+testConstraint testbytestring [llength [info commands testbytestring]]
test subst-1.1 {basics} -returnCodes error -body {
subst
} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}
test subst-1.2 {basics} -returnCodes error -body {
subst a b c
-} -result {bad switch "a": must be -nobackslashes, -nocommands, or -novariables}
+} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables}
test subst-2.1 {simple strings} {
subst {}
@@ -32,16 +36,16 @@ test subst-2.2 {simple strings} {
test subst-2.3 {simple strings} {
subst abcdefg
} abcdefg
-test subst-2.4 {simple strings} {
+test subst-2.4 {simple strings} testbytestring {
# Tcl Bug 685106
- subst [bytestring bar\x00soom]
-} [bytestring bar\x00soom]
+ expr {[subst [testbytestring bar\x00soom]] eq [testbytestring bar\x00soom]}
+} 1
test subst-3.1 {backslash substitutions} {
subst {\x\$x\[foo bar]\\}
} "x\$x\[foo bar]\\"
test subst-3.2 {backslash substitutions with utf chars} {
- # 'j' is just a char that doesn't mean anything, and \344 is 'ä'
+ # 'j' is just a char that doesn't mean anything, and \344 is 'ä'
# that also doesn't mean anything, but is multi-byte in UTF-8.
list [subst \j] [subst \\j] [subst \\344] [subst \\\344]
} "j j \344 \344"
@@ -119,13 +123,13 @@ test subst-6.1 {clear the result after command substitution} -body {
test subst-7.1 {switches} -returnCodes error -body {
subst foo bar
-} -result {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables}
+} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.2 {switches} -returnCodes error -body {
subst -no bar
-} -result {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables}
+} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.3 {switches} -returnCodes error -body {
subst -bogus bar
-} -result {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}
+} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables}
test subst-7.4 {switches} {
set x 123
subst -nobackslashes {abc $x [expr 1+2] \\\x41}
diff --git a/tests/switch.test b/tests/switch.test
index a03948b..4d204bb 100644
--- a/tests/switch.test
+++ b/tests/switch.test
@@ -169,7 +169,7 @@ test switch-4.1 {error in executed command} {
"switch a a {error "Just a test"} default {subst 1}"}}
test switch-4.2 {error: not enough args} -returnCodes error -body {
switch
-} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"}
+} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"}
test switch-4.3 {error: pattern with no body} -body {
switch a b
} -returnCodes error -result {extra switch pattern with no body}
@@ -269,16 +269,16 @@ test switch-8.3 {weird body text, variable} {
test switch-9.1 {empty pattern/body list} -returnCodes error -body {
switch x
-} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"}
+} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"}
test switch-9.2 {unpaired pattern} -returnCodes error -body {
switch -- x
} -result {extra switch pattern with no body}
test switch-9.3 {empty pattern/body list} -body {
switch x {}
-} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"}
+} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"}
test switch-9.4 {empty pattern/body list} -body {
switch -- x {}
-} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"}
+} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"}
test switch-9.5 {unpaired pattern} -body {
switch x a {} b
} -returnCodes error -result {extra switch pattern with no body}
diff --git a/tests/tailcall.test b/tests/tailcall.test
index 2d04f82..26f3cbf 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -147,6 +147,36 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup
rename b {}
} -result {0 0 0 0 0 0}
+test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup {
+ #
+ # This test is related to [bug d87cb182053fd79b3]: the fix to that bug was
+ # to remove a call to TclSkipTailcall, which caused a violation of the
+ # constant-space property of tailcall in that particular
+ # configuration. This test was added to detect that, and insure that the
+ # problem is fixed.
+ #
+
+ proc b i {
+ if {$i == 1} {
+ depthDiff
+ }
+ if {[incr i] > 10} {
+ return [depthDiff]
+ }
+ tailcall dict b $i
+ }
+ set map0 [namespace ensemble configure dict -map]
+ set map $map0
+ dict set map b b
+ namespace ensemble configure dict -map $map
+} -body {
+ dict b 0
+} -cleanup {
+ rename b {}
+ namespace ensemble configure dict -map $map0
+ unset map map0
+} -result {0 0 0 0 0 0}
+
test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup {
#
# This test fails because ns-unknown is not NR-enabled
diff --git a/tests/tcltest.test b/tests/tcltest.test
index ce8d617..e66678b 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -142,7 +142,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
} {0 1 1 1 1}
test tcltest-2.6 {tcltest -verbose 't'} {
- -constraints {unixOrPc}
+ -constraints {unixOrPc}
-body {
set result [slave msg test.tcl -verbose 't']
list $result $msg
@@ -152,7 +152,7 @@ test tcltest-2.6 {tcltest -verbose 't'} {
}
test tcltest-2.6a {tcltest -verbose 'start'} {
- -constraints {unixOrPc}
+ -constraints {unixOrPc}
-body {
set result [slave msg test.tcl -verbose start]
list $result $msg
@@ -169,7 +169,7 @@ test tcltest-2.7 {tcltest::verbose} {
verbose foo
set newVerbosity [verbose]
verbose $oldVerbosity
- list $currentVerbosity $newVerbosity
+ list $currentVerbosity $newVerbosity
}
-result {body {}}
}
@@ -217,7 +217,7 @@ test tcltest-3.5 {tcltest::match} {
}
-result {foo bar}
}
-
+
# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
set result [slave msg test.tcl -skip a* -verbose 'ps']
@@ -299,8 +299,8 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
# -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
# -cleanup {
# set ::tcltest::constraintsSpecified $constraintlist
-# unset ::tcltest::testConstraints(tcltestFakeConstraint1)
-# unset ::tcltest::testConstraints(tcltestFakeConstraint2)
+# unset ::tcltest::testConstraints(tcltestFakeConstraint1)
+# unset ::tcltest::testConstraints(tcltestFakeConstraint2)
# }
#}
@@ -348,7 +348,7 @@ set printerror [makeFile {
::tcltest::PrintError "a really really long string containing a \
\"Path/that/is/really/long/and/contains/no/spaces\""
::tcltest::PrintError "a really really long string containing a \
- \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
+ \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
@@ -367,7 +367,7 @@ test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
- $result1 $result2 [file exists a.tmp] [file delete a.tmp]
+ $result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
slave msg $printerror -errfile a.tmp
@@ -413,7 +413,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} {
set f2 [errorFile $ef]
set f3 [errorChannel]
set f4 [errorFile]
- subst {$f0;$f1;$f2;$f3;$f4}
+ subst {$f0;$f1;$f2;$f3;$f4}
}
-result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile}
-match regexp
@@ -449,7 +449,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
set f2 [outputFile $ef]
set f3 [outputChannel]
set f4 [outputFile]
- subst {$f0;$f1;$f2;$f3;$f4}
+ subst {$f0;$f1;$f2;$f3;$f4}
}
-result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile}
-match regexp
@@ -550,7 +550,7 @@ switch -- $::tcl_platform(platform) {
}
default {
catch {file attributes $notWriteableDir -readonly 1}
- catch {testchmod 000 $notWriteableDir}
+ catch {testchmod 0 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
@@ -717,7 +717,7 @@ switch -- $::tcl_platform(platform) {
file attributes $notWriteableDir -permissions 777
}
default {
- catch {testchmod 777 $notWriteableDir}
+ catch {testchmod 0o777 $notWriteableDir}
catch {file attributes $notWriteableDir -readonly 0}
}
}
@@ -758,7 +758,7 @@ test tcltest-9.3 {matchFiles} {
set new [matchFiles]
matchFiles $old
list $current $new
- }
+ }
-result {foo bar}
}
@@ -771,7 +771,7 @@ test tcltest-9.4 {skipFiles} {
set new [skipFiles]
skipFiles $old
list $current $new
- }
+ }
-result {foo bar}
}
@@ -1146,7 +1146,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
interp delete slave2
interp delete slave1
if {$oldoptions eq "none"} {
- unset ::env(TCLTEST_OPTIONS)
+ unset ::env(TCLTEST_OPTIONS)
} else {
set ::env(TCLTEST_OPTIONS) $oldoptions
}
@@ -1260,7 +1260,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
}
set foo 1
set expected 2
- }
+ }
-body {
incr foo
set foo
@@ -1424,7 +1424,7 @@ test tcltest-23.1 {makeFile} {
}
-cleanup {
file delete -force $mfdir \
- [file join [temporaryDirectory] t1.tmp]
+ [file join [temporaryDirectory] t1.tmp]
}
-result {1 1}
}
@@ -1447,7 +1447,7 @@ test tcltest-23.2 {removeFile} {
}
-cleanup {
file delete -force $mfdir \
- [file join [temporaryDirectory] t1.tmp]
+ [file join [temporaryDirectory] t1.tmp]
}
-result {0 0}
}
diff --git a/tests/thread.test b/tests/thread.test
index f32ef61..6032bae 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -564,7 +564,7 @@ test thread-7.14 {cancel: vwait} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
- [string map [list %ID [thread::id]] {
+ [string map [list %ID% [thread::id]] {
if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
@@ -616,7 +616,7 @@ test thread-7.16 {cancel: expr} -constraints {thread drainEventQueue} -setup {
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
- [string map [list %ID [thread::id]] {
+ [string map [list %ID% [thread::id]] {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
@@ -1372,7 +1372,7 @@ test thread-7.37 {cancel: send async thread cancel nested catch inside pure insi
unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
} -body {
set serverthread [thread::create -joinable \
- [string map [list %ID [thread::id]] {
+ [string map [list %ID% [thread::id]] {
proc foobar {} {
set catch catch
set while while
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index e4613ed..2d227fe 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -59,7 +59,7 @@ if {[testConstraint unix]} {
}
proc openup {path} {
- testchmod 777 $path
+ testchmod 0o777 $path
if {[file isdirectory $path]} {
catch {
foreach p [glob -directory $path *] {
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 ebab967..ceb1af7 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -16,50 +16,52 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
+testConstraint testbytestring [llength [info commands testbytestring]]
+
catch {unset x}
-test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
- set x \x01
-} [bytestring "\x01"]
-test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
- set x "\x00"
-} [bytestring "\xc0\x80"]
-test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
- set x "\xe0"
-} [bytestring "\xc3\xa0"]
-test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
- set x "\u4e4e"
-} [bytestring "\xe4\xb9\x8e"]
-test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} {
- format %c 0x110000
-} [bytestring "\xef\xbf\xbd"]
-test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
- format %c -1
-} [bytestring "\xef\xbf\xbd"]
+test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
+ expr {"\x01" eq [testbytestring "\x01"]}
+} 1
+test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
+ expr {"\x00" eq [testbytestring "\xc0\x80"]}
+} 1
+test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
+ expr {"\xe0" eq [testbytestring "\xc3\xa0"]}
+} 1
+test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring {
+ expr {"\u4e4e" eq [testbytestring "\xe4\xb9\x8e"]}
+} 1
+test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
+ expr {[format %c 0x110000] eq [testbytestring "\xef\xbf\xbd"]}
+} 1
+test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
+ expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]}
+} 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} {3}
-test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} {
- string length [bytestring "\x82\x83\x84"]
+test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring {
+ string length [testbytestring "\x82\x83\x84"]
} {3}
-test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} {
- string length [bytestring "\xC2"]
+test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring {
+ string length [testbytestring "\xC2"]
} {1}
-test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} {
- string length [bytestring "\xC2\xa2"]
+test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} testbytestring {
+ string length [testbytestring "\xC2\xa2"]
} {1}
-test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} {
- string length [bytestring "\xE2"]
+test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring {
+ string length [testbytestring "\xE2"]
} {1}
-test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} {
- string length [bytestring "\xE2\xA2"]
+test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring {
+ string length [testbytestring "\xE2\xA2"]
} {2}
-test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} {
- string length [bytestring "\xE4\xb9\x8e"]
+test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
+ string length [testbytestring "\xE4\xb9\x8e"]
} {1}
-test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} {
- string length [bytestring "\xF4\xA2\xA2\xA2"]
+test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring {
+ string length [testbytestring "\xF4\xA2\xA2\xA2"]
} {4}
test utf-3.1 {Tcl_UtfCharComplete} {
@@ -69,26 +71,26 @@ testConstraint testnumutfchars [llength [info commands testnumutfchars]]
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} {0}
-test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars {
- testnumutfchars [bytestring "\xC2\xA2"]
+test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xC2\xA2"]
} {1}
-test utf-4.3 {Tcl_NumUtfChars: long string} testnumutfchars {
- testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"]
+test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"]
} {7}
-test utf-4.4 {Tcl_NumUtfChars: #u0000} testnumutfchars {
- testnumutfchars [bytestring "\xC0\x80"]
+test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
testnumutfchars "" 1
} {0}
-test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} testnumutfchars {
- testnumutfchars [bytestring "\xC2\xA2"] 1
+test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xC2\xA2"] 1
} {1}
-test utf-4.7 {Tcl_NumUtfChars: long string, calc len} testnumutfchars {
- testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1
+test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1
} {7}
-test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} testnumutfchars {
- testnumutfchars [bytestring "\xC0\x80"] 1
+test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xC0\x80"] 1
} {1}
test utf-5.1 {Tcl_UtfFindFirsts} {
@@ -125,18 +127,18 @@ test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
set x \n
} {
}
-test utf-10.2 {Tcl_UtfBackslash: \u subst} {
- set x \ua2
-} [bytestring "\xc2\xa2"]
-test utf-10.3 {Tcl_UtfBackslash: longer \u subst} {
- set x \u4e21
-} [bytestring "\xe4\xb8\xa1"]
-test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} {
- set x \u4e2k
-} "[bytestring \xd3\xa2]k"
-test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} {
- set x \u4e216
-} "[bytestring \xe4\xb8\xa1]6"
+test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring {
+ expr {"\ua2" eq [testbytestring "\xc2\xa2"]}
+} 1
+test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring {
+ expr {"\u4e21" eq [testbytestring "\xe4\xb8\xa1"]}
+} 1
+test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
+ expr {"\u4e2k" eq "[testbytestring \xd3\xa2]k"}
+} 1
+test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
+ expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"}
+} 1
proc bsCheck {char num} {
global errNum
test utf-10.$errNum {backslash substitution} {
@@ -285,23 +287,25 @@ 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} {
} {}
test utf-21.1 {TclUniCharIsAlnum} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
string is alnum \u1040\u021f\u0220
} {1}
test utf-21.2 {unicode alnum char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220]
} {1 1}
test utf-21.3 {unicode print char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
regexp {^[[:print:]]+$} \ufbc1
} 1
test utf-21.4 {TclUniCharIsGraph} {
@@ -334,11 +338,11 @@ test utf-21.10 {unicode print char in regc_locale.c} {
} {0}
test utf-21.11 {TclUniCharIsControl} {
# [Bug 3464428]
- string is control \u00ad
+ string is control \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff
} {1}
test utf-21.12 {unicode control char in regc_locale.c} {
# [Bug 3464428], [Bug a876646efe]
- regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad
+ regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff
} {1}
test utf-22.1 {TclUniCharIsWordChar} {
@@ -349,30 +353,30 @@ test utf-22.2 {TclUniCharIsWordChar} {
} 10
test utf-23.1 {TclUniCharIsAlpha} {
- # this returns 1 with Unicode 6 compliance
- string is alpha \u021f\u0220
+ # this returns 1 with Unicode 7 compliance
+ string is alpha \u021f\u0220\u037f\u052f
} {1}
test utf-23.2 {unicode alpha char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
- regexp {^[[:alpha:]]+$} \u021f\u0220
+ # this returns 1 with Unicode 7 compliance
+ regexp {^[[:alpha:]]+$} \u021f\u0220\u037f\u052f
} {1}
test utf-24.1 {TclUniCharIsDigit} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
string is digit \u1040\uabf0
} {1}
test utf-24.2 {unicode digit char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
+ # this returns 1 with Unicode 7 compliance
list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0]
} {1 1}
test utf-24.3 {TclUniCharIsSpace} {
- # this returns 1 with Unicode 6 compliance
- string is space \u1680\u180e
+ # this returns 1 with Unicode 7/TIP 413 compliance
+ string is space \u0085\u1680\u180e\u200b\u202f\u2060
} {1}
test utf-24.4 {unicode space char in regc_locale.c} {
- # this returns 1 with Unicode 6 compliance
- list [regexp {^[[:space:]]+$} \u1680\u180e] [regexp {^\s+$} \u1680\u180e]
+ # this returns 1 with Unicode 7/TIP 413 compliance
+ list [regexp {^[[:space:]]+$} \u0085\u1680\u180e\u200b\u202f\u2060] [regexp {^\s+$} \u0085\u1680\u180e\u200b\u202f\u2060]
} {1 1}
testConstraint teststringobj [llength [info commands teststringobj]]
diff --git a/tests/util.test b/tests/util.test
index 0e50483..7782f35 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -16,6 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint controversialNaN 1
+testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
@@ -274,10 +275,10 @@ test util-5.17 {Tcl_StringMatch: UTF-8} {
# get 1 UTF-8 character
Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
-test util-5.18 {Tcl_StringMatch: UTF-8} {
+test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
- Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [bytestring a\u008fc]
+ Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\u008fc]
} 0
test util-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
diff --git a/tests/var.test b/tests/var.test
index 26b4efa..0531746 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -290,7 +290,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}
@@ -866,6 +866,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 28a0e9f..a808c82 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -208,22 +208,11 @@ test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup {
} -constraints {win win2000orXP testfile} -body {
testfile mv nul tf1
} -returnCodes error -result EINVAL
-test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} -setup {
+test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup {
cleanup
} -constraints {win nt winOlderThan2000 testfile} -body {
testfile mv nul tf1
} -returnCodes error -result EACCES
-test winFCmd-1.13.2 {TclpRenameFile: errno: ENOENT} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result ENOENT
-test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- createfile tf1
- testfile mv tf1 nul
-} -returnCodes error -result EACCES
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup {
cleanup
} -constraints {win nt testfile} -body {
@@ -257,11 +246,6 @@ test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup {
} -constraints {win nt winOlderThan2000 testfile} -body {
testfile mv nul tf1
} -returnCodes error -result EACCES
-test winFCmd-1.19.2 {TclpRenameFile: errno == ENOENT} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- testfile mv nul tf1
-} -returnCodes error -result ENOENT
test winFCmd-1.20 {TclpRenameFile: src is dir} -setup {
cleanup
} -constraints {win nt testfile} -body {
@@ -351,12 +335,12 @@ test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup {
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \
-constraints {win exdev testfile testchmod} -body {
file mkdir d:/td1
- testchmod 000 d:/td1
+ testchmod 0 d:/td1
file mkdir c:/tf1
catch {testfile mv c:/tf1 d:/td1} msg
list $msg [file writable d:/td1]
} -cleanup {
- catch {testchmod 666 d:/td1}
+ catch {testchmod 0o666 d:/td1}
file delete d:/td1
file delete -force c:/tf1
} -result {EXDEV 0}
@@ -474,29 +458,14 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup {
} -returnCodes error -result ENOENT
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup {
cleanup
-} -constraints {win 95 testfile} -body {
- createfile tf1
- set fd [open tf2 w]
- testfile cp tf1 tf2
-} -cleanup {
- close $fd
- cleanup
-} -returnCodes error -result EACCES
-test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup {
- cleanup
} -constraints {win win2000orXP testfile} -body {
testfile cp nul tf1
} -returnCodes error -result EINVAL
-test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} -setup {
+test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup {
cleanup
} -constraints {win nt winOlderThan2000 testfile} -body {
testfile cp nul tf1
} -returnCodes error -result EACCES
-test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- testfile cp nul tf1
-} -returnCodes error -result ENOENT
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -520,11 +489,11 @@ test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} -setup {
cleanup
} -constraints {win testfile} -body {
createfile tf1 tf1
- testchmod 000 tf1
+ testchmod 0 tf1
testfile cp tf1 tf2
list [contents tf2] [file writable tf2]
} -cleanup {
- catch {testchmod 666 tf1}
+ catch {testchmod 0o666 tf1}
cleanup
} -result {tf1 0}
test winFCmd-2.13 {TclpCopyFile: CopyFile fails} -setup {
@@ -566,24 +535,13 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup {
} -constraints {win testfile testchmod} -body {
createfile tf1 tf1
createfile tf2 tf2
- testchmod 000 tf2
+ testchmod 0 tf2
testfile cp tf1 tf2
list [file writable tf2] [contents tf2]
} -cleanup {
- catch {testchmod 666 tf2}
+ catch {testchmod 0o666 tf2}
cleanup
} -result {1 tf1}
-test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} -setup {
- cleanup
-} -constraints {win 95 testfile testchmod} -body {
- createfile tf1
- createfile tf2
- testchmod 000 tf2
- set fd [open tf2]
- set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
- close $fd
- lappend msg [file writable tf2]
-} -result {1 EACCES 0}
test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} -body {
testfile rm $cdfile $cdrom/dummy~~.fil
@@ -647,7 +605,7 @@ test winFCmd-3.10 {TclpDeleteFile: path is readonly} -setup {
cleanup
} -constraints {win testfile testchmod} -body {
createfile tf1
- testchmod 000 tf1
+ testchmod 0 tf1
testfile rm tf1
file exists tf1
} -result {0}
@@ -655,20 +613,17 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup {
cleanup
} -constraints {win testfile testchmod} -body {
set fd [open tf1 w]
- testchmod 000 tf1
+ testchmod 0 tf1
testfile rm tf1
} -cleanup {
close $fd
- catch {testchmod 666 tf1}
+ catch {testchmod 0o666 tf1}
cleanup
} -returnCodes error -result EACCES
test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body {
testfile mkdir $cdrom/dummy~~.dir
} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES
-test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} -body {
- testfile mkdir $cdrom/dummy~~.dir
-} -constraints {win 95 cdrom testfile} -returnCodes error -result ENOSPC
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -703,11 +658,11 @@ test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
file mkdir td1
- testchmod 000 td1
+ testchmod 0 td1
testfile rmdir td1
file exists td1
} -returnCodes error -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {td1 EACCES}
# This next test has a very hokey way of matching...
@@ -757,18 +712,13 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
file mkdir td1
- testchmod 000 td1
+ testchmod 0 td1
testfile rmdir td1
file exists td1
} -returnCodes error -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {td1 EACCES}
-test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- testfile rmdir nul
-} -returnCodes error -result {nul EACCES}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
cleanup
} -constraints {win nt testfile} -body {
@@ -776,38 +726,18 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$}
-# This next test has a very hokey way of matching...
-test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- createfile tf1
- set res [catch {testfile rmdir tf1} msg]
- # get rid of path
- set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]]
- list $res $msg
-} -result {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
file mkdir td1
- testchmod 000 td1
+ testchmod 0 td1
testfile rmdir td1
file exists td1
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -returnCodes error -result {td1 EACCES}
# This next test has a very hokey way of matching...
-test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- file mkdir td1/td2
- set res [catch {testfile rmdir td1} msg]
- # get rid of path
- set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]]
- list $res $msg
-} -result {1 {td1 EEXIST}}
-# This next test has a very hokey way of matching...
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup {
cleanup
} -constraints {win testfile} -body {
@@ -887,11 +817,6 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup {
} -cleanup {
cleanup
} -result {tf1}
-test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} -body {
- # cdrom can return either d:\ or D:/, but we only care about the errcode
- testfile rmdir $cdrom/
-} -constraints {win 95 cdrom testfile} -returnCodes error -match glob \
- -result {* EACCES} ; # was EEXIST, but changed for win98.
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body {
testfile rmdir $cdrom/
} -constraints {win nt cdrom testfile} -returnCodes error -match glob \
@@ -905,11 +830,11 @@ test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} -setup {
} -constraints {win testfile testchmod} -body {
file mkdir td1
createfile td1/tf1 tf1
- testchmod 000 td1
+ testchmod 0 td1
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {1 1}
test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} -setup {
@@ -930,14 +855,6 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup {
} -cleanup {
cleanup
} -result {tf1}
-test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- file mkdir td1
- testfile cpdir td1 /
-} -cleanup {
- cleanup
-} -returnCodes error -result {/ EEXIST}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup {
cleanup
} -constraints {win nt testfile} -body {
@@ -984,11 +901,11 @@ test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} -setup {
} -constraints {win testfile testchmod} -body {
file mkdir td1
createfile td1/tf1 tf1
- testchmod 000 td1
+ testchmod 0 td1
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {1 1}
test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} -setup {
@@ -1015,11 +932,11 @@ test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} -setup {
cleanup
} -constraints {win testfile testchmod} -body {
file mkdir td1/td2
- testchmod 000 td1
+ testchmod 0 td1
testfile cpdir td1 td2
list [file writable td1] [file writable td1/td2]
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -result {0 1}
test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} -setup {
@@ -1038,24 +955,15 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup {
createfile td1/tf1
testfile rmdir -force td1
} -result {}
-test winFCmd-9.2 {TraversalDelete: DOTREE_F} -setup {
- cleanup
-} -constraints {win 95 testfile} -body {
- file mkdir td1
- set fd [open td1/tf1 w]
- testfile rmdir -force td1
-} -cleanup {
- close $fd
-} -returnCodes error -result {td1\tf1 EACCES}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
cleanup
} -constraints {winVista testfile testchmod} -body {
file mkdir td1/td2
- testchmod 000 td1
+ testchmod 0 td1
testfile rmdir -force td1
file exists td1
} -cleanup {
- catch {testchmod 666 td1}
+ catch {testchmod 0o666 td1}
cleanup
} -returnCodes error -result {td1 EACCES}
test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} -setup {
@@ -1406,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"
@@ -1477,10 +1385,10 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
list [catch {
set f [open $tmpfile [list WRONLY CREAT]]
close $f
- } res] errormsg ;#$res
+ } res] $res
} -cleanup {
catch {file delete $tmpfile}
-} -result [list 1 errormsg]
+} -result [list 0 {}]
test winFCmd-19.6 {Windows extended path names} -constraints nt -setup {
set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
set tmpfile //?/[file normalize $tmpfile]
@@ -1515,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} {
diff --git a/tests/winFile.test b/tests/winFile.test
index fba9bcb..2c47f5f 100644
--- a/tests/winFile.test
+++ b/tests/winFile.test
@@ -37,24 +37,6 @@ test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body {
# The administrator account should always exist.
glob ~administrator
} -match glob -result *
-test winFile-1.3 {TclpGetUserHome} -constraints {win 95} -body {
- # Find some user in system.ini and then see if they have a home.
-
- set f [open $::env(windir)/system.ini]
- while {[gets $f line] >= 0} {
- if {$line ne {[Password Lists]}} {
- continue
- }
- gets $f
- set name [lindex [split [gets $f] =] 0]
- if {$name ne ""} {
- return [catch {glob ~$name}]
- }
- }
- return 0 ;# didn't find anything...
-} -cleanup {
- catch {close $f}
-} -result {0}
test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
diff --git a/tests/winPipe.test b/tests/winPipe.test
index d2e804d..9c6f94d 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -82,10 +82,6 @@ test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat3
exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
-test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {win 95 exec cat32} {
- exec command /c type $path(big) |& $cat32 > $path(stdout) 2> $path(stderr)
- list [contents $path(stdout)] [contents $path(stderr)]
-} "{$big} stderr32"
test winpipe-1.6 {32 bit comprehensive tests: from console} \
{win cat32 AllocConsole} {
# would block waiting for human input
@@ -174,10 +170,6 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
catch {close $f}
set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
-test winpipe-1.22 {Checking command.com for Win95/98 hanging} {win 95 exec} {
- exec command.com /c dir /b
- set result 1
-} 1
test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
proc readResults {f} {
diff --git a/tests/zlib.test b/tests/zlib.test
index 0712929..b1d43fb 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -16,6 +16,13 @@ if {"::tcltest" ni [namespace children]} {
}
testConstraint zlib [llength [info commands zlib]]
+testConstraint recentZlib 0
+catch {
+ # Work around a bug in some versions of zlib; known to manifest on at
+ # least Mac OS X Mountain Lion...
+ testConstraint recentZlib \
+ [package vsatisfies [zlib::pkgconfig get zlibVersion] 1.2.6]
+}
test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body {
zlib
@@ -28,7 +35,7 @@ test zlib-1.3 {zlib basics} -constraints zlib -body {
} -result zlibVersion
test zlib-1.4 {zlib basics} -constraints zlib -body {
package present zlib
-} -result 2.0
+} -result 2.0.1
test zlib-2.1 {zlib compress/decompress} zlib {
zlib decompress [zlib compress abcdefghijklm]
@@ -208,7 +215,7 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup {
set ::res
} -cleanup {
catch {close $r}
-} -result {qwertyuiop MIDDLE asdfghjkl}
+} -result {qwertyuiop MIDDLE asdfghjkl {}}
test zlib-8.6 {transformation and fconfigure} -setup {
set file [makeFile {} test.z]
set fd [open $file wb]
@@ -269,7 +276,7 @@ test zlib-8.9 {transformation and fconfigure} -setup {
} -result {3064818174 358 358}
test zlib-8.10 {transformation and fconfigure} -setup {
lassign [chan pipe] inSide outSide
-} -constraints zlib -body {
+} -constraints {zlib recentZlib} -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
fconfigure $inSide -blocking 0 -translation binary