summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2016-06-16 15:19:41 (GMT)
committerdgp <dgp@users.sourceforge.net>2016-06-16 15:19:41 (GMT)
commit9899c6d8097c67a31bc107c77ff8848bcc23d6db (patch)
treef824e5fe9e245730af806b3a5aabf69b2c8e1e08 /tests
parentb700360ad9501defb0b1e2d86353ac8d0db8eef4 (diff)
parent3f61f168eb9d98c28312cdea25b214827c3692f2 (diff)
downloadtcl-9899c6d8097c67a31bc107c77ff8848bcc23d6db.zip
tcl-9899c6d8097c67a31bc107c77ff8848bcc23d6db.tar.gz
tcl-9899c6d8097c67a31bc107c77ff8848bcc23d6db.tar.bz2
Merge up to a197e6853e. Still works. Next checkin restarts the segfaults.
Diffstat (limited to 'tests')
-rw-r--r--tests/assemble.test3
-rw-r--r--tests/assocd.test30
-rw-r--r--tests/autoMkindex.test32
-rw-r--r--tests/basic.test32
-rw-r--r--tests/binary.test56
-rw-r--r--tests/chanio.test14
-rw-r--r--tests/cmdAH.test13
-rw-r--r--tests/cmdIL.test9
-rw-r--r--tests/cmdInfo.test8
-rw-r--r--tests/compile.test6
-rw-r--r--tests/coroutine.test2
-rw-r--r--tests/dcall.test8
-rw-r--r--tests/dict.test18
-rw-r--r--tests/env.test6
-rw-r--r--tests/error.test152
-rw-r--r--tests/exec.test2
-rw-r--r--tests/expr-old.test14
-rw-r--r--tests/fCmd.test10
-rw-r--r--tests/fileSystem.test23
-rw-r--r--tests/for.test134
-rw-r--r--tests/http.test23
-rw-r--r--tests/httpd2
-rw-r--r--tests/info.test460
-rw-r--r--tests/interp.test14
-rw-r--r--tests/listObj.test4
-rw-r--r--tests/lmap.test19
-rw-r--r--tests/main.test26
-rw-r--r--tests/misc.test7
-rw-r--r--tests/msgcat.test16
-rw-r--r--tests/namespace.test8
-rw-r--r--tests/nre.test26
-rw-r--r--tests/oo.test118
-rw-r--r--tests/parse.test57
-rw-r--r--tests/parseExpr.test8
-rw-r--r--tests/parseOld.test22
-rw-r--r--tests/pkgMkIndex.test16
-rw-r--r--tests/platform.test17
-rw-r--r--tests/reg.test78
-rw-r--r--tests/regexp.test61
-rw-r--r--tests/rename.test7
-rw-r--r--tests/result.test6
-rw-r--r--tests/safe.test80
-rw-r--r--tests/scan.test763
-rw-r--r--tests/set-old.test5
-rw-r--r--tests/set.test5
-rw-r--r--tests/stack.test6
-rw-r--r--tests/string.test6
-rw-r--r--tests/subst.test4
-rwxr-xr-xtests/tcltest.test17
-rw-r--r--tests/thread.test22
-rw-r--r--tests/tm.test2
-rw-r--r--tests/trace.test368
-rw-r--r--tests/unixFCmd.test15
-rw-r--r--tests/unixForkEvent.test45
-rw-r--r--tests/unixInit.test16
-rw-r--r--tests/unknown.test10
-rw-r--r--tests/utf.test4
-rw-r--r--tests/var.test69
-rw-r--r--tests/zlib.test19
59 files changed, 2229 insertions, 794 deletions
diff --git a/tests/assemble.test b/tests/assemble.test
index 7d4e5d1..b0487e6 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} {
-match glob
-result {1 {extra characters after close-brace} {extra characters after close-brace
while executing
-"{}extra
- "
+"{}e"
("assemble" body, line 2)*}}
}
test assemble-4.2 {null command} {
diff --git a/tests/assocd.test b/tests/assocd.test
index d1489b3..edf55c4 100644
--- a/tests/assocd.test
+++ b/tests/assocd.test
@@ -11,10 +11,8 @@
# 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
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -36,15 +34,21 @@ test assocd-1.4 {testing setting assoc data} testsetassocdata {
testsetassocdata abc "abc d e f"
} ""
-test assocd-2.1 {testing getting assoc data} testgetassocdata {
- testgetassocdata a
-} 2
-test assocd-2.2 {testing getting assoc data} testgetassocdata {
- testgetassocdata 123
-} 456
-test assocd-2.3 {testing getting assoc data} testgetassocdata {
+test assocd-2.1 {testing getting assoc data} -setup {
+ testsetassocdata a 2
+} -constraints {testgetassocdata} -body {
+ testgetassocdata a
+} -result 2
+test assocd-2.2 {testing getting assoc data} -setup {
+ testsetassocdata 123 456
+} -constraints {testgetassocdata} -body {
+ testgetassocdata 123
+} -result 456
+test assocd-2.3 {testing getting assoc data} -setup {
+ testsetassocdata abc "abc d e f"
+} -constraints {testgetassocdata} -body {
testgetassocdata abc
-} {abc d e f}
+} -result "abc d e f"
test assocd-2.4 {testing getting assoc data} testgetassocdata {
testgetassocdata xxx
} ""
@@ -60,5 +64,5 @@ test assocd-3.3 {testing deleting assoc data} testdelassocdata {
} {0 {}}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test
index 8f29131..4721553 100644
--- a/tests/autoMkindex.test
+++ b/tests/autoMkindex.test
@@ -236,6 +236,38 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} -setup {
# Reset initCommands to avoid trashing other tests
AutoMkindexTestReset
} -result "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}"
+makeFile {
+
+namespace eval wok {
+ namespace ensemble create -subcommands {commands vars}
+
+ proc commands {{pattern *}} {
+ puts [join [lsort -dictionary [info commands $pattern]] \n]
+ }
+
+ proc vars {{pattern *}} {
+ puts [join [lsort -dictionary [info vars $pattern]] \n]
+ }
+
+}
+
+} ensemblecommands.tcl
+
+test autoMkindex-3.4 {ensemble commands in tclIndex} {
+ file delete tclIndex
+ auto_mkindex . ensemblecommands.tcl
+ set f [open tclIndex r]
+ set dat [list]
+ foreach r [split [string trim [read $f]] "\n"] {
+ if {[string match {set auto_index*} $r]} {
+ lappend dat $r
+ }
+ }
+ set result [lsort $dat]
+ close $f
+ set result
+} {{set auto_index(::wok::commands) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(::wok::vars) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(wok) [list source [file join $dir ensemblecommands.tcl]]}}
+removeFile ensemblecommands.tcl
test autoMkindex-4.1 {platform independent source commands} -setup {
file delete tclIndex
diff --git a/tests/basic.test b/tests/basic.test
index 7435571..1a0037c 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -16,7 +16,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
-namespace import -force ::tcltest::*
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -31,7 +31,7 @@ catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
-catch {unset x}
+unset -nocomplain x
test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
catch {interp delete test_interp}
@@ -267,14 +267,24 @@ test basic-18.4 {TclRenameCommand, bad new name} {
}
rename test_ns_basic::p :::george::martha
} {}
-test basic-18.5 {TclRenameCommand, new name must not already exist} {
+test basic-18.5 {TclRenameCommand, new name must not already exist} -setup {
+ if {![llength [info commands :::george::martha]]} {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ namespace eval test_ns_basic {
+ proc p {} {
+ return "p in [namespace current]"
+ }
+ }
+ rename test_ns_basic::p :::george::martha
+ }
+} -body {
namespace eval test_ns_basic {
proc q {} {
return 42
}
}
list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
-} {1 {can't rename to ":::george::martha": command already exists}}
+} -result {1 {can't rename to ":::george::martha": command already exists}}
test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
@@ -302,7 +312,7 @@ test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespace
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
- catch {unset x}
+ unset -nocomplain x
set x [namespace eval test_ns_basic::test_ns_basic2 {
# the following creates a cmd in the global namespace
testcmdtoken create p
@@ -355,7 +365,7 @@ test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
catch {interp delete test_interp}
- catch {unset x}
+ unset -nocomplain x
interp create test_interp
interp eval test_interp {
proc useSet {} {
@@ -427,7 +437,7 @@ test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup {
# string would have been freed, leaving garbage bytes for the error
# message.
set f [open $fName w]
- fileevent $f writable "fileevent $f writable {}; error foo"
+ chan event $f writable "chan event $f writable {}; error foo"
set x {}
vwait x
close $f
@@ -547,8 +557,8 @@ test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
catch {close $f}
set res [catch {
set f [open |[list [interpreter]] w+]
- fconfigure $f -buffering line
- puts $f {fconfigure stdout -buffering line}
+ chan configure $f -buffering line
+ puts $f {chan configure stdout -buffering line}
puts $f continue
puts $f {puts $::errorInfo}
puts $f {puts DONE}
@@ -972,6 +982,6 @@ catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
-catch {unset x}
-::tcltest::cleanupTests
+unset -nocomplain x
+cleanupTests
return
diff --git a/tests/binary.test b/tests/binary.test
index ccd0f29..4393245 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -1582,38 +1582,46 @@ test binary-40.4 {ScanNumber: NaN} -body {
list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1
} -match glob -result {1 -NaN*}
-test binary-41.1 {ScanNumber: word alignment} {
- unset -nocomplain arg1; unset arg2
+test binary-41.1 {ScanNumber: word alignment} -setup {
+ unset -nocomplain arg1 arg2
+} -body {
list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2
-} {2 1 1}
-test binary-41.2 {ScanNumber: word alignment} {
- unset -nocomplain arg1; unset arg2
+} -result {2 1 1}
+test binary-41.2 {ScanNumber: word alignment} -setup {
+ unset -nocomplain arg1 arg2
+} -body {
list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2
-} {2 1 1}
-test binary-41.3 {ScanNumber: word alignment} {
- unset -nocomplain arg1; unset arg2
+} -result {2 1 1}
+test binary-41.3 {ScanNumber: word alignment} -setup {
+ unset -nocomplain arg1 arg2
+} -body {
list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2
-} {2 1 1}
-test binary-41.4 {ScanNumber: word alignment} {
- unset -nocomplain arg1; unset arg2
+} -result {2 1 1}
+test binary-41.4 {ScanNumber: word alignment} -setup {
+ unset -nocomplain arg1 arg2
+} -body {
list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2
-} {2 1 1}
-test binary-41.5 {ScanNumber: word alignment} bigEndian {
- unset -nocomplain arg1; unset arg2
+} -result {2 1 1}
+test binary-41.5 {ScanNumber: word alignment} -setup {
+ unset -nocomplain arg1 arg2
+} -constraints bigEndian -body {
list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2
-} {2 1 1.600000023841858}
-test binary-41.6 {ScanNumber: word alignment} littleEndian {
- unset -nocomplain arg1; unset arg2
+} -result {2 1 1.600000023841858}
+test binary-41.6 {ScanNumber: word alignment} -setup {
+ unset -nocomplain arg1 arg2
+} -constraints littleEndian -body {
list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2
-} {2 1 1.600000023841858}
-test binary-41.7 {ScanNumber: word alignment} bigEndian {
- unset -nocomplain arg1; unset arg2
+} -result {2 1 1.600000023841858}
+test binary-41.7 {ScanNumber: word alignment} -setup {
+ unset -nocomplain arg1 arg2
+} -constraints bigEndian -body {
list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2
-} {2 1 1.6}
-test binary-41.8 {ScanNumber: word alignment} littleEndian {
- unset -nocomplain arg1; unset arg2
+} -result {2 1 1.6}
+test binary-41.8 {ScanNumber: word alignment} -setup {
+ unset -nocomplain arg1 arg2
+} -constraints littleEndian -body {
list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
-} {2 1 1.6}
+} -result {2 1 1.6}
test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} -constraints {} -body {
binary ?
diff --git a/tests/chanio.test b/tests/chanio.test
index 665df50..999d0bb 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -2214,13 +2214,17 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup {
puts $sok DONE
exit 0
} echo.tcl]
-} -body {
+ variable done
+ unset -nocomplain done
+ set done ""
+ set timer ""
set ff [openpipe r $echo]
gets $ff port
+} -body {
set s [socket 127.0.0.1 $port]
puts $s Hey
close $s w
- set timer [after 1000 [namespace code {set ::done Failed}]]
+ set timer [after 1000 [namespace code {set done Failed}]]
set acc {}
fileevent $s readable [namespace code {
if {[gets $s line]<0} {
@@ -2230,11 +2234,11 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup {
}
}]
vwait [namespace which -variable done]
- after cancel $timer
- close $s r
- close $ff
list $done $acc
} -cleanup {
+ catch {close $s}
+ close $ff
+ after cancel $timer
removeFile echo.tcl
} -result {Succeeded {Hey DONE}}
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 3051bfb..39e9ece 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -954,6 +954,19 @@ test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup {
removeFile /tmp/tcl.foo.dir/file
removeDirectory /tmp/tcl.foo.dir
} -result 0
+test cmdAH-19.12 {Bug 3608360: [file exists] mustn't do globbing} -setup {
+ set newdirfile [makeDirectory newdir.file]
+ set cwd [pwd]
+ cd $newdirfile
+ # Content of file is totally unimportant; name is *not*
+ set innocentBystander [makeFile "abc" [file join $newdirfile foo.bar]]
+} -body {
+ list [file exists foo.bar] [file exists *.bar]
+} -cleanup {
+ cd $cwd
+ removeFile $innocentBystander
+ removeDirectory $newdirfile
+} -result {1 0}
# Stat related commands
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 721773f..23a5f96 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -417,6 +417,15 @@ test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} {
test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} {
lsort -ascii -nocase {d E c B a D35 d300 100 20}
} {100 20 a B c d d300 D35 E}
+test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} {
+ scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c
+} {257 32 256}
+test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} {
+ scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c
+} {97 32 97 0 97}
+test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} {
+ scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c
+} {97 32 97 0 97}
test cmdIL-5.1 {lsort with list style index} {
lsort -ascii -decreasing -index {0 1} {
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index 69d7171..0a587e8 100644
--- a/tests/cmdInfo.test
+++ b/tests/cmdInfo.test
@@ -13,10 +13,8 @@
# 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::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -101,7 +99,7 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} \
# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
-::tcltest::cleanupTests
+cleanupTests
return
# Local Variables:
diff --git a/tests/compile.test b/tests/compile.test
index 4d91940..51db0a2 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -707,6 +707,12 @@ test compile-18.19 {disassembler - basics} -setup {
} -cleanup {
foo destroy
} -match glob -result *
+
+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 *
+
# TODO sometime - check that bytecode from tbcload is *not* disassembled.
# cleanup
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 8272717..1d9040b 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -439,7 +439,7 @@ test coroutine-4.5 {bug #2724403} -constraints {memory} \
} -result 0
test coroutine-4.6 {compile context, bug #3282869} -setup {
- unset ::x
+ unset -nocomplain ::x
proc f x {
coroutine D eval {yield X$x;yield Y}
}
diff --git a/tests/dcall.test b/tests/dcall.test
index 3df0ac8..41dd777 100644
--- a/tests/dcall.test
+++ b/tests/dcall.test
@@ -11,10 +11,8 @@
# 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
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -41,5 +39,5 @@ test dcall-1.6 {deletion callbacks} testdcall {
} {}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/dict.test b/tests/dict.test
index 72a336c..02c9050 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -668,6 +668,24 @@ test dict-14.20 {dict for stack space compilation: bug 1903325} {
concat "c=$y,$args"
}} {} 1 2 3
} {c=1,2 3}
+test dict-14.21 {compiled dict for and break} {
+ apply {{} {
+ dict for {a b} {c d e f} {
+ lappend result $a,$b
+ break
+ }
+ return $result
+ }}
+} c,d
+test dict-14.22 {dict for and exception range depths: Bug 3614382} {
+ apply {{} {
+ dict for {a b} {c d} {
+ dict for {e f} {g h} {
+ return 5
+ }
+ }
+ }}
+} 5
# There's probably a lot more tests to add here. Really ought to use a
# coverage tool for this job...
diff --git a/tests/env.test b/tests/env.test
index 9010f52..fa76433 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -70,7 +70,7 @@ set printenvScript [makeFile {
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
- regsub -all {[\u0000-\u001f\u007f-\uffff]} $s {[manglechar &]} s
+ regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s
return [subst -novariables $s]
}
proc manglechar c {
@@ -89,7 +89,7 @@ set printenvScript [makeFile {
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
- CommonProgramFiles ProgramFiles
+ CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
} {
lrem names $name
}
@@ -121,7 +121,7 @@ foreach name [array names env] {
SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
SECURITYSESSIONID LANG WINDIR TERM
- CommonProgramFiles ProgramFiles
+ CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432
}} {
unset env($name)
}
diff --git a/tests/error.test b/tests/error.test
index 97bcc0a..06f8eca 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
testConstraint memory [llength [info commands memory]]
+customMatch pairwise {apply {{a b} {
+ string equal [lindex $b 0] [lindex $b 1]
+}}}
namespace eval ::tcl::test::error {
if {[testConstraint memory]} {
proc getbytes {} {
@@ -314,6 +317,12 @@ test error-8.8 {throw syntax checks} -returnCodes error -body {
test error-8.9 {throw syntax checks} -returnCodes error -body {
throw {} foo
} -result {type must be non-empty list}
+test error-8.10 {Bug 33b7abb8a2: throw stack usage} -returnCodes error -body {
+ apply {code {throw $code foo}} {}
+} -result {type must be non-empty list}
+test error-8.11 {Bug 7174354ecb: throw error message} -returnCodes error -body {
+ throw {not {}a list} x[]y
+} -result {list element in braces followed by "a" instead of space}
# simple try tests: body completes with code ok
@@ -601,21 +610,21 @@ test error-16.7 {try with variable assignment and propagation #2} {
}
list $em [dict get $opts -errorcode]
} {bar FOO}
-test error-16.8 {exception chaining (try=ok, handler=error)} {
+test error-16.8 {exception chaining (try=ok, handler=error)} -body {
#FIXME is the intent of this test correct?
catch {
try { list a b c } on ok {em opts} { throw BAR baz }
} tryem tryopts
- string equal $opts [dict get $tryopts -during]
-} {1}
-test error-16.9 {exception chaining (try=error, handler=error)} {
+ list $opts [dict get $tryopts -during]
+} -match pairwise -result equal
+test error-16.9 {exception chaining (try=error, handler=error)} -body {
# The exception off the handler should chain to the exception off the
# try-body (using the -during option)
catch {
try { throw FOO bar } trap {} {em opts} { throw BAR baz }
} tryem tryopts
- string equal $opts [dict get $tryopts -during]
-} {1}
+ list $opts [dict get $tryopts -during]
+} -match pairwise -result equal
test error-16.10 {no exception chaining when handler is successful} {
catch {
try { throw FOO bar } trap {} {em opts} { list d e f }
@@ -628,6 +637,131 @@ test error-16.11 {no exception chaining when handler is a non-error exception} {
} tryem tryopts
dict exists $tryopts -during
} {0}
+test error-16.12 {compiled try with successfully executed handler} {
+ apply {{} {
+ try { throw FOO bar } trap FOO {} { list a b c }
+ }}
+} {a b c}
+test error-16.13 {compiled try with exception (error) in handler} -body {
+ apply {{} {
+ try { throw FOO bar } trap FOO {} { throw BAR foo }
+ }}
+} -returnCodes error -result {foo}
+test error-16.14 {compiled try with exception (return) in handler} -body {
+ apply {{} {
+ list [catch {
+ try { throw FOO bar } trap FOO {} { return BAR }
+ } msg] $msg
+ }}
+} -result {2 BAR}
+test error-16.15 {compiled try with exception (break) in handler} {
+ apply {{} {
+ for { set i 5 } { $i < 10 } { incr i } {
+ try { throw FOO bar } trap FOO {} { break }
+ }
+ return $i
+ }}
+} {5}
+test error-16.16 {compiled try with exception (continue) in handler} {
+ apply {{} {
+ for { set i 5 } { $i < 10 } { incr i } {
+ try { throw FOO bar } trap FOO {} { continue }
+ incr i 20
+ }
+ return $i
+ }}
+} {10}
+test error-16.17 {compiled try with variable assignment and propagation #1} {
+ # Ensure that the handler variables preserve the exception off the
+ # try-body, and are not modified by the exception off the handler
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap FOO {em} { throw BAR baz }
+ }
+ return $em
+ }}
+} {bar}
+test error-16.18 {compiled try with variable assignment and propagation #2} {
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap FOO {em opts} { throw BAR baz }
+ }
+ list $em [dict get $opts -errorcode]
+ }}
+} {bar FOO}
+test error-16.19 {compiled try exception chaining (try=ok, handler=error)} -body {
+ #FIXME is the intent of this test correct?
+ apply {{} {
+ catch {
+ try { list a b c } on ok {em opts} { throw BAR baz }
+ } tryem tryopts
+ list $opts [dict get $tryopts -during]
+ }}
+} -match pairwise -result equal
+test error-16.20 {compiled try exception chaining (try=error, handler=error)} -body {
+ # The exception off the handler should chain to the exception off the
+ # try-body (using the -during option)
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap {} {em opts} { throw BAR baz }
+ } tryem tryopts
+ list $opts [dict get $tryopts -during]
+ }}
+} -match pairwise -result equal
+test error-16.21 {compiled try exception chaining (try=error, finally=error)} {
+ # The exception off the handler should chain to the exception off the
+ # try-body (using the -during option)
+ apply {{} {
+ catch {
+ try { throw FOO bar } finally { throw BAR baz }
+ } tryem tryopts
+ dict get $tryopts -during -errorcode
+ }}
+} FOO
+test error-16.22 {compiled try: no exception chaining when handler is successful} {
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap {} {em opts} { list d e f }
+ } tryem tryopts
+ dict exists $tryopts -during
+ }}
+} {0}
+test error-16.23 {compiled try: no exception chaining when handler is a non-error exception} {
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap {} {em opts} { break }
+ } tryem tryopts
+ dict exists $tryopts -during
+ }}
+} {0}
+test error-16.24 {compiled try exception chaining (try=ok, handler=error, finally=error)} -body {
+ apply {{} {
+ catch {
+ try {
+ list a b c
+ } on ok {em opts} {
+ throw BAR baz
+ } finally {
+ throw DING dong
+ }
+ } tryem tryopts
+ list $opts [dict get $tryopts -during -during]
+ }}
+} -match pairwise -result equal
+test error-16.25 {compiled try exception chaining (all errors)} -body {
+ apply {{} {
+ catch {
+ try {
+ throw FOO bar
+ } on error {em opts} {
+ throw BAR baz
+ } finally {
+ throw DING dong
+ }
+ } tryem tryopts
+ list $opts [dict get $tryopts -during -during]
+ }}
+} -match pairwise -result equal
# try tests - finally
@@ -709,15 +843,15 @@ test error-18.5 {exception in finally doesn't affect variable assignment} {
}
list $em [dict get $opts -errorcode]
} {bar FOO}
-test error-18.6 {exception chaining in finally (try=ok)} {
+test error-18.6 {exception chaining in finally (try=ok)} -body {
catch {
list a b c
} em expopts
catch {
try { list a b c } finally { throw BAR foo }
} em opts
- string equal $expopts [dict get $opts -during]
-} {1}
+ list $expopts [dict get $opts -during]
+} -match pairwise -result equal
test error-18.7 {exception chaining in finally (try=error)} {
catch {
try { throw FOO bar } finally { throw BAR baz }
diff --git a/tests/exec.test b/tests/exec.test
index 64d3517..871c0c5 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -157,7 +157,7 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
- regsub -all {[\u007f-\uffff]} $s \
+ regsub -all "\[\u007f-\uffff\]" $s \
{[apply {c {format {\u%04x} [scan $c %c]}} &]} s
return [subst -novariables $s]
}
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 4f3cb2e..06a00ba 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -13,10 +13,8 @@
# 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.1
- namespace import -force ::tcltest::*
-}
+package require tcltest 2.1
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -145,7 +143,7 @@ test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
test expr-old-1.53 {integer operators} {
- catch {unset x}
+ unset -nocomplain x
set x yes
list [expr {1 && $x}] [expr {$x && 1}] \
[expr {0 || $x}] [expr {$x || 0}]
@@ -453,7 +451,7 @@ test expr-old-23.3 {double quotes} {
test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22
test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc}
test expr-old-23.6 {double quotes} {
- catch {unset bogus__}
+ unset -nocomplain bogus__
list [catch {expr {"$bogus__"}} msg] $msg
} {1 {can't read "bogus__": no such variable}}
test expr-old-23.7 {double quotes} {
@@ -502,7 +500,7 @@ test expr-old-26.2 {error conditions} -body {
test expr-old-26.3 {error conditions} -body {
expr 2+4*(
} -returnCodes error -match glob -result *
-catch {unset _non_existent_}
+unset -nocomplain _non_existent_
test expr-old-26.4 {error conditions} {
list [catch {expr 2+$_non_existent_} msg] $msg
} {1 {can't read "_non_existent_": no such variable}}
@@ -581,7 +579,7 @@ test expr-old-27.4 {cancelled evaluation} {
expr {1?2:[set a 2]}
set a
} 1
-catch {unset x}
+unset -nocomplain x
test expr-old-27.5 {cancelled evaluation} {
list [catch {expr {[info exists x] && $x}} msg] $msg
} {0 0}
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 325b374..8f27ad4 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -2441,14 +2441,17 @@ test fCmd-28.12 {file link: cd into a link} -setup {
return "ok"
}
} -cleanup {
+ file delete -force abc.link
cd [workingDirectory]
} -result ok
test fCmd-28.13 {file link} -constraints {linkDirectory} -setup {
cd [temporaryDirectory]
+ file link abc.link abc.dir
} -body {
# duplicate link throws error
file link abc.link abc.dir
} -returnCodes error -cleanup {
+ file delete -force abc.link
cd [workingDirectory]
} -result {could not create new link "abc.link": that path already exists}
test fCmd-28.14 {file link: deletes link not dir} -setup {
@@ -2469,6 +2472,7 @@ test fCmd-28.15.1 {file link: copies link not dir} -setup {
# directory, not a link (links trace to endpoint).
list [file type abc2.link] [file tail [file link abc.link]]
} -cleanup {
+ file delete -force abc.link
cd [workingDirectory]
} -result {directory abc.dir}
test fCmd-28.15.2 {file link: copies link not dir} -setup {
@@ -2479,6 +2483,7 @@ test fCmd-28.15.2 {file link: copies link not dir} -setup {
file copy abc.link abc2.link
list [file type abc2.link] [file tail [file link abc2.link]]
} -cleanup {
+ file delete -force abc.link
cd [workingDirectory]
} -result {link abc.dir}
cd [temporaryDirectory]
@@ -2498,20 +2503,25 @@ test fCmd-28.16 {file link: glob inside link} -setup {
file link abc.link abc.dir
lsort [glob -dir abc.link -tails *]
} -cleanup {
+ file delete -force abc.link
cd [workingDirectory]
} -result {abc.file abc2.file}
test fCmd-28.17 {file link: glob -type l} -setup {
cd [temporaryDirectory]
+ file link abc.link abc.dir
} -constraints {linkDirectory} -body {
glob -dir [pwd] -type l -tails abc*
} -cleanup {
+ file delete -force abc.link
cd [workingDirectory]
} -result {abc.link}
test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup {
cd [temporaryDirectory]
+ file link abc.link abc.dir
} -body {
lsort [glob -dir [pwd] -type d -tails abc*]
} -cleanup {
+ file delete -force abc.link
cd [workingDirectory]
} -result [lsort [list abc.link abc.dir abc2.dir]]
test fCmd-28.19 {file link: relative paths} -setup {
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index b098f35..942a86c 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -138,13 +138,18 @@ test filesystem-1.9 {link normalisation} -setup {
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
[file normalize [file join dir.link inside.file foo]]
} -result ok
-test filesystem-1.10 {link normalisation: double link} {unix hasLinks} {
+test filesystem-1.10 {link normalisation: double link} -constraints {
+ unix hasLinks
+} -body {
file link dir2.link dir.link
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
[file normalize [file join dir2.link inside.file foo]]
-} ok
+} -cleanup {
+ file delete dir2.link
+} -result ok
makeDirectory dir2.file
test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} {
+ file link dir2.link dir.link
file link [file join dir2.file dir2.link] [file join .. dir2.link]
testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
[file normalize [file join dir2.file dir2.link inside.file foo]]
@@ -373,7 +378,9 @@ test filesystem-2.0 {new native path} {unix} {
# Make sure the testfilesystem hasn't been registered.
if {[testConstraint testfilesystem]} {
+ proc resetfs {} {
while {![catch {testfilesystem 0}]} {}
+ }
}
test filesystem-3.1 {Tcl_FSRegister & Tcl_FSUnregister} testfilesystem {
@@ -388,12 +395,14 @@ test filesystem-3.3 {Tcl_FSRegister} testfilesystem {
testfilesystem 0
testfilesystem 0
} {unregistered}
-test filesystem-3.4 {Tcl_FSRegister} testfilesystem {
+test filesystem-3.4 {Tcl_FSRegister} -constraints testfilesystem -body {
testfilesystem 1
file system bar
-} {reporting}
-test filesystem-3.5 {Tcl_FSUnregister} testfilesystem {
+} -cleanup {
testfilesystem 0
+} -result {reporting}
+test filesystem-3.5 {Tcl_FSUnregister} testfilesystem {
+ resetfs
lindex [file system bar] 0
} {native}
@@ -632,7 +641,7 @@ test filesystem-7.4 {cross-filesystem file copy with -force} -setup {
file delete -force simplefile
file delete -force file2
cd $dir
-} -result {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1}
+} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1}
test filesystem-7.5 {cross-filesystem file copy with -force} -setup {
set dir [pwd]
cd [tcltest::temporaryDirectory]
@@ -657,7 +666,7 @@ test filesystem-7.5 {cross-filesystem file copy with -force} -setup {
file delete -force simplefile
file delete -force file2
cd $dir
-} -result {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1}
+} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1}
test filesystem-7.6 {cross-filesystem dir copy with -force} -setup {
set dir [pwd]
cd [tcltest::temporaryDirectory]
diff --git a/tests/for.test b/tests/for.test
index ff4dc0e..8936682 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -14,6 +14,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc meminfo {} {lindex [split [memory info] "\n"] 3 3}
+}
+
# Basic "for" operation.
test for-1.1 {TclCompileForCmd: missing initial command} {
@@ -345,7 +351,6 @@ proc formatMail {} {
64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \
65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \
}
-
set result ""
set NL "
"
@@ -365,7 +370,6 @@ proc formatMail {} {
} else {
set break 1
}
-
set xmailer 0
set inheaders 1
set last [array size lines]
@@ -386,9 +390,7 @@ proc formatMail {} {
set limit 55
} else {
set limit 55
-
# Decide whether or not to break the body line
-
if {$plen > 0} {
if {[string first {> } $line] == 0} {
# This is quoted text from previous message, don't reformat
@@ -431,7 +433,7 @@ proc formatMail {} {
set climit [expr $limit-1]
set cutoff 50
set continuation 0
-
+
while {[string length $line] > $limit} {
for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} {
set char [string index $line $c]
@@ -824,7 +826,127 @@ test for-6.18 {Tcl_ForObjCmd: for command result} {
1 {invoked "continue" outside of a loop} \
]
-
+test for-7.1 {Bug 3614226: ensure that break 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 [break] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.2 {Bug 3614226: ensure that continue 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 [continue] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.3 {Bug 3614226: ensure that break 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 {*}[break] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.4 {Bug 3614226: ensure that continue 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 {*}[continue] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.5 {Bug 3614226: ensure that break 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 {*}[break] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.6 {Bug 3614226: ensure that continue 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 {*}[continue] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.7 {Bug 3614226: ensure that break 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 {*}[break] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.8 {Bug 3614226: ensure that continue 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 {*}[continue] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/http.test b/tests/http.test
index 9861e0e..7d439b1 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -135,6 +135,7 @@ 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
+set authorityurl //[info hostname]:$port
set ipv6url http://\[::1\]:$port/
test http-3.4 {http::geturl} -body {
set token [http::geturl $url]
@@ -391,7 +392,7 @@ Connection close
Content-Type {text/plain;charset=utf-8}
Accept-Encoding .*
Content-Length 5}
-test http-3.29 "http::geturl $ipv6url" -body {
+test http-3.29 {http::geturl IPv6 address} -body {
# We only want to see if the URL gets parsed correctly. This is
# the case if http::geturl succeeds or returns a socket related
# error. If the parsing is wrong, we'll get a parse error.
@@ -405,7 +406,18 @@ test http-3.29 "http::geturl $ipv6url" -body {
} -cleanup {
catch { http::cleanup $token }
} -result 0
-
+test http-3.30 {http::geturl query without path} -body {
+ set token [http::geturl $authorityurl?var=val]
+ http::ncode $token
+} -cleanup {
+ catch { http::cleanup $token }
+} -result 200
+test http-3.31 {http::geturl fragment without path} -body {
+ set token [http::geturl "$authorityurl#fragment42"]
+ http::ncode $token
+} -cleanup {
+ catch { http::cleanup $token }
+} -result 200
test http-4.1 {http::Event} -body {
set token [http::geturl $url -keepalive 0]
upvar #0 $token data
@@ -547,11 +559,10 @@ test http-4.14 {http::Event} -body {
error "bogus return from http::geturl"
}
http::wait $token
- http::status $token
- # error code varies among platforms.
-} -returnCodes 1 -match regexp -cleanup {
+ lindex [http::error $token] 0
+} -cleanup {
catch {http::cleanup $token}
-} -result {(connect failed|couldn't open socket)}
+} -result {connect failed connection refused}
# Bogus host
test http-4.15 {http::Event} -body {
# This test may fail if you use a proxy server. That is to be
diff --git a/tests/httpd b/tests/httpd
index f810797..232e80a 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -40,7 +40,7 @@ proc httpdAccept {newsock ipaddr port} {
fconfigure $newsock -blocking 0 -translation {auto crlf}
httpd_log $newsock Connect $ipaddr $port
set data(ipaddr) $ipaddr
- fileevent $newsock readable [list httpdRead $newsock]
+ after 50 [list fileevent $newsock readable [list httpdRead $newsock]]
}
# read data from a client request
diff --git a/tests/info.test b/tests/info.test
index 5078e11..3057dd2 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -692,31 +692,31 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
##
# ### ### ### ######### ######### #########
## info frame
+
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
+
proc reduce {frame} {
- set pos [lsearch -exact $frame cmd]
- incr pos
- set cmd [lindex $frame $pos]
+ set cmd [dict get $frame cmd]
if {[regexp \n $cmd]} {
- set first [string range [lindex [split $cmd \n] 0] 0 end-4]
- set frame [lreplace $frame $pos $pos $first]
+ dict set frame cmd \
+ [string range [lindex [split $cmd \n] 0] 0 end-4]
}
- set pos [lsearch -exact $frame file]
- if {$pos >=0} {
- incr pos
- set tail [file tail [lindex $frame $pos]]
- set frame [lreplace $frame $pos $pos $tail]
+ if {[dict exists $frame file]} {
+ dict set frame file \
+ [file tail [dict get $frame file]]
}
- set frame
+ return $frame
}
+
proc subinterp {} { interp create sub ; interp debug sub -frame 1;
interp eval sub [list proc reduce [info args reduce] [info body reduce]]
}
+
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
@@ -1454,9 +1454,9 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body {
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
- [reduce [info frame 0]];# line 1457
+ [info frame 0];# line 1457
}
- return $xxx::res
+ return [reduce $xxx::res]
} {type source line 1457 file info.test cmd {info frame 0} level 0}
test info-30.3 {bs+nl in literal words, namespace multi-word script} {
@@ -1962,6 +1962,440 @@ test info-9.13 {info level option, value in global context} -body {
} -returnCodes error -result {bad level "2"}
# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ catch {*}{
+ {info frame 0}
+ res
+ }
+ return $res
+}
+test info-33.4 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ dict for {a b} {c d} {*}{
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.5 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ set d {a b}
+ dict update d x y {*}{
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.6 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ set d {}
+ dict with d {*}{
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.7 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ for {*}{
+ {set res [info frame 0]}
+ {1} {} {break}
+ }
+ return $res
+}
+test info-33.8 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ for {*}{
+ {} {1} {}
+ {set res [info frame 0]; break}
+ }
+ return $res
+}
+test info-33.9 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ for {*}{
+ {} {1}
+ {return [info frame 0]}
+ {}
+ }
+}
+test info-33.10 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ for {*}{
+ {}
+ {[return [info frame 0]]}
+ {} {}
+ }
+}
+test info-33.11 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ foreach {*}{
+ x
+ } [return [info frame 0]] {}
+}
+test info-33.12 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ foreach {*}{
+ x y
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.13 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ if {*}{
+ {[return [info frame 0]]}
+ {}
+ }
+}
+test info-33.14 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ if 0 {*}{
+ {} else
+ {return [info frame 0]}
+ }
+}
+test info-33.15 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ incr {*}{
+ x
+ } [return [info frame 0]]
+}
+test info-33.16 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ info level {*}{
+ } [return [info frame 0]]
+}
+test info-33.17 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ string match {*}{
+ } [return [info frame 0]] {}
+}
+test info-33.18 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ string match {*}{
+ {}
+ } [return [info frame 0]]
+}
+test info-33.19 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ string length {*}{
+ } [return [info frame 0]]
+}
+test info-33.20 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ while {*}{
+ {[return [info frame 0]]}
+ } {}
+}
+test info-33.21 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ switch -- {*}{
+ } [return [info frame 0]] {*}{
+ } x y
+}
+test info-33.22 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {*}{
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.23 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {*}{
+ {set res [info frame 0]}
+ } finally {}
+ return $res
+}
+test info-33.24 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {*}{
+ {set res [info frame 0]}
+ } on ok {} {}
+ return $res
+}
+test info-33.25 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {*}{
+ {set res [info frame 0]}
+ } on ok {} {} finally {}
+ return $res
+}
+test info-33.26 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ while 1 {*}{
+ {return [info frame 0]}
+ }
+}
+test info-33.27 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {} finally {*}{
+ {return [info frame 0]}
+ }
+}
+test info-33.28 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {} on ok {} {} finally {*}{
+ {return [info frame 0]}
+ }
+}
+test info-33.29 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {} on ok {} {*}{
+ {return [info frame 0]}
+ }
+}
+test info-33.30 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {} on ok {} {*}{
+ {return [info frame 0]}
+ } finally {}
+}
+test info-33.31 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ binary format {*}{
+ } [return [info frame 0]]
+}
+test info-33.32 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ set format format
+ binary $format {*}{
+ } [return [info frame 0]]
+}
+test info-33.33 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ append x {*}{
+ } [return [info frame 0]]
+}
+test info-33.34 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ append {*}{
+ } x([return [info frame 0]]) {*}{
+ } a
+}
+test info-33.35 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
diff --git a/tests/interp.test b/tests/interp.test
index 0af9887..ad99fac 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -1599,6 +1599,20 @@ test interp-20.50 {Bug 2486550} -setup {
} -cleanup {
interp delete slave
} -returnCodes error -match glob -result *
+test interp-20.50.1 {Bug 2486550} -setup {
+ interp create slave
+} -body {
+ slave hide coroutine
+ catch {slave invokehidden coroutine} m o
+ dict get $o -errorinfo
+} -cleanup {
+ unset -nocomplain m 0
+ interp delete slave
+} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?"
+ while executing
+"coroutine"
+ invoked from within
+"slave invokehidden coroutine"}
test interp-21.1 {interp hidden} {
interp hidden {}
diff --git a/tests/listObj.test b/tests/listObj.test
index 8b24aa9..d7fb46c 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -196,6 +196,10 @@ test listobj-10.1 {Bug [2971669]} {*}{
-result {{a b c d e} {} {a b c d e f}}
}
+test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj {
+ testobj bug3598580
+} 123
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/lmap.test b/tests/lmap.test
index 7baa77b..08035d9 100644
--- a/tests/lmap.test
+++ b/tests/lmap.test
@@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} {
namespace import -force ::tcltest::*
}
-unset -nocomplain a i x
+unset -nocomplain a b i x
# ----- Non-compiled operation -----------------------------------------------
@@ -404,14 +404,21 @@ test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup {
rename demo {}
} -result {2 4}
# Huge lists must not overflow the bytecode interpreter (development bug)
-test lmap-7.7 {huge list non-compiled} {
+test lmap-7.7 {huge list non-compiled} -setup {
+ unset -nocomplain a b x
+} -body {
set x [lmap a [lrepeat 1000000 x] { set b y$a }]
list $b [llength $x] [string length $x]
-} {yx 1000000 2999999}
-test lmap-7.8 {huge list compiled} {
- set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000]
+} -result {yx 1000000 2999999}
+test lmap-7.8 {huge list compiled} -setup {
+ unset -nocomplain a b x
+} -body {
+ set x [apply {{times} {
+ global b
+ lmap a [lrepeat $times x] { set b Y$a }
+ }} 1000000]
list $b [llength $x] [string length $x]
-} {yx 1000000 2999999}
+} -result {Yx 1000000 2999999}
test lmap-7.9 {error then dereference loop var (dev bug)} {
catch { lmap a 0 b {1 2 3} { error x } }
set a
diff --git a/tests/main.test b/tests/main.test
index f1dc7fd..351fd4f 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -129,7 +129,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -150,7 +150,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -171,7 +171,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -592,7 +592,7 @@ namespace eval ::tcl::test::main {
catch {set f [open "|[list [interpreter]]" w+]}
} -body {
type $f {
- fconfigure stdin -blocking 0
+ chan configure stdin -blocking 0
puts SUCCESS
}
list [catch {gets $f} line] $line
@@ -606,19 +606,19 @@ namespace eval ::tcl::test::main {
exec
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
- type $f "fconfigure stdin -eofchar \\032
+ type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
- fileevent $f readable \
+ chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 2000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
- if {[string equal timeout $wait] && [testConstraint unix]} {
+ if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
close $f
@@ -631,17 +631,17 @@ namespace eval ::tcl::test::main {
} -setup {
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
variable wait
- fileevent $f readable \
+ chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 2000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
- if {[string equal timeout $wait] && [testConstraint unix]} {
+ if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
close $f
@@ -748,7 +748,7 @@ namespace eval ::tcl::test::main {
exec Tcltest
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
type $f "testsetmainloop
after 2000 testexitmainloop
@@ -983,7 +983,7 @@ namespace eval ::tcl::test::main {
} -body {
exec [interpreter] << {
testsetmainloop
- fconfigure stdin -blocking 0
+ chan configure stdin -blocking 0
testexitmainloop
} >& result
set f [open result]
diff --git a/tests/misc.test b/tests/misc.test
index 6ddc718..d4ece74 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} {
missing close-brace for variable name
missing close-brace for variable name
while executing
-"set tst $a([winfo name $\{zz)
- # this is a bogus comment
- # this is a bogus comment
- # this is a bogus comment
- # this is a bogus comment
- # this is a ..."
+"set tst $a([winfo name $\{"
(procedure "tstProc" line 4)
invoked from within
"tstProc"}]
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 1522354..050b592 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -12,13 +12,13 @@
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
-package require Tcl 8.2
+package require Tcl 8.5
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
-if {[catch {package require msgcat 1.5.0}]} {
- puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test."
+if {[catch {package require msgcat 1.5}]} {
+ puts stderr "Skipping tests in [info script]. No msgcat 1.5 found to test."
return
}
@@ -56,7 +56,7 @@ namespace eval ::msgcat::test {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
- if {([info sharedlibextension] == ".dll")
+ if {([info sharedlibextension] eq ".dll")
&& ![catch {package require registry}]} {
# Windows and Cygwin have other ways to determine the
# locale when the environment variables are missing
@@ -72,7 +72,7 @@ namespace eval ::msgcat::test {
variable var
foreach var $envVars {
catch {variable $var $::env($var)}
- catch {unset ::env($var)}
+ unset -nocomplain ::env($var)
}
foreach var $setVars {
set ::env($var) $var
@@ -84,13 +84,13 @@ namespace eval ::msgcat::test {
} -cleanup {
interp delete [namespace current]::i
foreach var $envVars {
- catch {unset ::env($var)}
+ unset -nocomplain ::env($var)
catch {set ::env($var) [set [namespace current]::$var]}
}
} -body {i eval msgcat::mclocale} -result $result
incr count
}
- catch {unset result}
+ unset -nocomplain result
# Could add tests of initialization from Windows registry here.
# Use a fake registry package.
@@ -324,7 +324,7 @@ namespace eval ::msgcat::test {
incr count
}
}
- catch {unset result}
+ unset -nocomplain result
# Tests msgcat-4.*: [mcunknown]
diff --git a/tests/namespace.test b/tests/namespace.test
index 1d46bf0..f6688f1 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -1111,6 +1111,14 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} {
}
list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello]
} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]
+test namespace-26.8 {NamespaceExportCmd, -clear resets export list} {
+ catch {namespace delete foo}
+ namespace eval foo {
+ namespace export x
+ namespace export -clear
+ }
+ list [namespace eval foo namespace export] [namespace delete foo]
+} {{} {}}
test namespace-27.1 {NamespaceForgetCmd, no args} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
diff --git a/tests/nre.test b/tests/nre.test
index b8ef2e0..b5eb032 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -74,7 +74,6 @@ test nre-1.1 {self-recursive procs} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-1.2 {self-recursive lambdas} -setup {
set a [list i [makebody {apply $::a $i}]]
} -body {
@@ -85,7 +84,6 @@ test nre-1.2 {self-recursive lambdas} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-1.3 {mutually recursive procs and lambdas} -setup {
proc a i {
apply $::b [incr i]
@@ -164,8 +162,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup {
namespace delete ::foo
} -constraints {
testnrelevels
-} -result {{0 3 2 2} 0}
-
+} -result {{0 2 2 2} 0}
test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace eval ::foo {
setabs
@@ -177,7 +174,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace delete ::foo
} -constraints {
testnrelevels
-} -result {{0 3 2 2} 0}
+} -result {{0 2 2 2} 0}
test nre-6.1 {[uplevel] is not recursive} -setup {
proc a i [makebody {uplevel 1 [list a $i]}]
@@ -189,7 +186,6 @@ test nre-6.1 {[uplevel] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-6.2 {[uplevel] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "set x $i; a $i"}]
@@ -211,7 +207,6 @@ test nre-7.1 {[catch] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
-
test nre-7.2 {[if] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
@@ -222,7 +217,6 @@ test nre-7.2 {[if] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.3 {[while] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
@@ -233,7 +227,6 @@ test nre-7.3 {[while] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.4 {[for] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
@@ -244,7 +237,6 @@ test nre-7.4 {[for] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.5 {[foreach] is not recursive} -setup {
#
# Enable once [foreach] is NR-enabled
@@ -258,7 +250,6 @@ test nre-7.5 {[foreach] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
-
test nre-7.6 {[eval] is not recursive} -setup {
proc a i [makebody {eval [list a $i]}]
} -body {
@@ -269,7 +260,6 @@ test nre-7.6 {[eval] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
-
test nre-7.7 {[eval] is not recursive} -setup {
proc a i [makebody {eval "a $i"}]
} -body {
@@ -280,7 +270,6 @@ test nre-7.7 {[eval] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
-
test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
proc foo args {}
foo
@@ -295,18 +284,15 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
} -body {
# if switching to plain eval is not nre aware, this will cause a "cannot
# yield" error
-
list [bar] [bar] [bar]
} -cleanup {
rename bar {}
rename foo {}
} -result {1 2 3}
-
test nre-8.1 {nre and {*}} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the TEBCdataPtr. This crashes on failure.
-
proc inner {} {
set long [lrepeat 1000000 1]
list {*}$long
@@ -321,21 +307,18 @@ test nre-8.2 {nre and {*}, [Bug 2415422]} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the bcFramePtr. This causes an NRE assertion to fail if it is not
# done properly.
-
proc nop {} {}
proc crash {} {
foreach val [list {*}[lrepeat 100000 x]] {
nop
}
}
-
crash
} -cleanup {
rename nop {}
rename crash {}
}
-
#
# Basic TclOO tests
#
@@ -351,7 +334,6 @@ test nre-oo.1 {really deep calls in oo - direct} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {[self] bar $i}]
@@ -363,7 +345,6 @@ test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.3 {really deep calls in oo - private calls} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {my bar $i}]
@@ -375,7 +356,6 @@ test nre-oo.3 {really deep calls in oo - private calls} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.4 {really deep calls in oo - overriding} -setup {
oo::class create foo {
method bar i [makebody {my bar $i}]
@@ -392,7 +372,6 @@ test nre-oo.4 {really deep calls in oo - overriding} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.5 {really deep calls in oo - forwards} -setup {
oo::object create foo
set body [makebody {my boo $i}]
@@ -409,7 +388,6 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup {
testnrelevels
} -result {{0 2 1 1} 0}
-
#
# NASTY BUG found by tcllib's interp package
#
diff --git a/tests/oo.test b/tests/oo.test
index 5d34077..e0e0791 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -936,6 +936,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup {
} -returnCodes error -cleanup {
fooClass destroy
} -result {wrong # args: should be "::foo len string"}
+test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup {
+ oo::object create foo
+ unset -nocomplain ::result
+ set ::result {}
+} -body {
+ proc ::my {method} {lappend ::result global}
+ oo::objdefine foo {
+ method target {} {lappend ::result instance}
+ forward bar my target
+ method bump {} {
+ set ns [info object namespace ::foo]
+ rename ${ns}::my ${ns}::
+ rename ${ns}:: ${ns}::my
+ }
+ }
+ proc harness {} {
+ foo target
+ foo bar
+ foo target
+ }
+ trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
+ foo target
+ foo bar
+ foo bump
+ foo bar
+ harness
+} -cleanup {
+ catch {rename harness {}}
+ catch {rename ::my {}}
+ foo destroy
+} -result {instance instance instance instance instance instance}
+test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup {
+ oo::class create fooClass
+ fooClass create foo
+ unset -nocomplain ::result
+ set ::result {}
+} -body {
+ proc ::my {method} {lappend ::result global}
+ oo::define fooClass {
+ method target {} {lappend ::result class}
+ forward bar my target
+ method bump {} {
+ set ns [info object namespace [self]]
+ rename ${ns}::my ${ns}::
+ rename ${ns}:: ${ns}::my
+ }
+ }
+ proc harness {} {
+ foo target
+ foo bar
+ foo target
+ }
+ trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
+ foo target
+ foo bar
+ foo bump
+ foo bar
+ harness
+} -cleanup {
+ catch {rename harness {}}
+ catch {rename ::my {}}
+ fooClass destroy
+} -result {class class class class class class}
test oo-7.1 {OO: inheritance 101} -setup {
oo::class create superClass
@@ -2204,6 +2267,25 @@ test oo-19.2 {OO: varname method: Bug 2883857} -setup {
} -cleanup {
SpecialClass destroy
} -result ::oo_test::x(y)
+test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup {
+ oo::class create testClass {
+ variable foo
+ export varname
+ constructor {} {
+ variable foo x
+ }
+ method bar {obj} {
+ my varname foo
+ $obj varname foo
+ }
+ }
+} -body {
+ testClass create A
+ testClass create B
+ lsearch [list [A varname foo] [B varname foo]] [B bar A]
+} -cleanup {
+ testClass destroy
+} -result 0
test oo-20.1 {OO: variable method} -body {
oo::class create testClass {
@@ -3355,6 +3437,42 @@ test oo-34.8 {TIP 380: slots - presence} {
test oo-34.9 {TIP 380: slots - presence} {
getMethods oo::objdefine::variable
} {{-append -clear -set} {Get Set}}
+
+test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
+ oo::class create fruit {
+ method eat {} {}
+ }
+ set result {}
+} -body {
+ lappend result [fruit create ::apple] [info class superclasses fruit]
+ oo::define fruit superclass
+ lappend result [info class superclasses fruit] \
+ [info object class apple oo::object] \
+ [info class call fruit destroy] \
+ [catch { apple }]
+} -cleanup {
+ unset -nocomplain result
+ fruit destroy
+} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1}
+test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
+ oo::class create fruitMetaclass {
+ superclass oo::class
+ method eat {} {}
+ }
+ set result {}
+} -body {
+ lappend result [fruitMetaclass create ::appleClass] \
+ [appleClass create orange] \
+ [info class superclasses fruitMetaclass]
+ oo::define fruitMetaclass superclass
+ lappend result [info class superclasses fruitMetaclass] \
+ [info object class appleClass oo::class] \
+ [catch { orange }] [info object class orange] \
+ [appleClass create pear]
+} -cleanup {
+ unset -nocomplain result
+ fruitMetaclass destroy
+} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear}
cleanupTests
return
diff --git a/tests/parse.test b/tests/parse.test
index 0f76d64..01443c9 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -26,6 +26,8 @@ testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
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
@@ -438,7 +440,7 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
- catch {unset x}
+ unset -nocomplain x
list [catch {testevalex {for {} 1 {} {
@@ -479,7 +481,7 @@ test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex {
testevalex {concat [expr 2 + 6]}
} {8}
test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xxx[expr $a]}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex {
@@ -487,21 +489,21 @@ test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex {
testevalex {concat $a}
} {hello}
test parse-10.6 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
set a(12) 46
testevalex {concat $a(12)}
} {46}
test parse-10.7 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
set a(12) 46
testevalex {concat $a(1[expr 3 - 1])}
} {46}
test parse-10.8 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat $x($a)}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.9 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xyz$a(1)}} msg] $msg
} {1 {can't read "a(1)": no such variable}}
test parse-10.10 {Tcl_EvalTokens, object values} testevalex {
@@ -541,11 +543,11 @@ test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex {
list [catch {testevalex {concat "abc}} msg] $msg
} {1 {missing "}}
test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xyz $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {_bogus_ a b c d}} msg] $msg
} {1 {invalid command name "_bogus_"}}
test parse-11.5 {Tcl_EvalEx, exceptional return} testevalex {
@@ -564,7 +566,7 @@ test parse-11.8 {Tcl_EvalEx, multiple commands in script} testevalex {
}] $a $c
} {d b d}
test parse-11.9 {Tcl_EvalEx, freeing memory after error} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-11.10 {Tcl_EvalTokens, empty commands} testevalex {
@@ -670,13 +672,33 @@ test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar {
testparsevar {$.123}
} {{$} .123}
test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar {
- catch {unset abc}
+ unset -nocomplain abc
list [catch {testparsevar {$abc}} msg] $msg
} {1 {can't read "abc": no such variable}}
test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar {
- catch {unset abc}
+ unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
+test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup {
+ proc getbytes {} {
+ return [lindex [split [memory info] \n] 3 3]
+ }
+} -body {
+ set a() foo
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ set vn {}
+ set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]]
+ if {$res ne {foo bar}} {error "Unexpected result: $res"}
+
+ set tmp $end
+ set end [getbytes]
+ }
+ expr {$end - $tmp}
+} -cleanup {
+ unset -nocomplain a end i vn res tmp
+ rename getbytes {}
+} -result 0
test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -1090,6 +1112,19 @@ test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
+test parse-21.0 {Bug 1884496} testevent {
+ set ::script {testevent delete a; set a [p]; set ::done $a}
+ proc ::p {} {string first s $::script}
+ testevent queue a head $::script
+ vwait done
+} {}
+test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent {
+ testevent queue a head {testevent delete a; \
+ set ::done [dict get [info frame 0] line]}
+ vwait done
+ set ::done
+} 2
+
cleanupTests
}
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 7910974..714c45b 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -8,10 +8,8 @@
# 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::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -1067,5 +1065,5 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body {
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 0edcbf0..f3b1591 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -13,10 +13,8 @@
# 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
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -166,25 +164,25 @@ test parseOld-5.6 {variable substitution} {
set msg
} {can't read "_non_existent_": no such variable}
test parseOld-5.7 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set a(xyz) 123
set b $a(xyz)foo
set b
} 123foo
test parseOld-5.8 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set "a(x y z)" 123
set b $a(x y z)foo
set b
} 123foo
test parseOld-5.9 {array variable substitution} {
- catch {unset a}; catch {unset qqq}
+ unset -nocomplain a qqq
set "a(x y z)" qqq
set $a([format x]\ y [format z]) foo
set qqq
} foo
test parseOld-5.10 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
list [catch {set b $a(22)} msg] $msg
} {1 {can't read "a(22)": no such variable}}
test parseOld-5.11 {array variable substitution} {
@@ -194,9 +192,9 @@ test parseOld-5.11 {array variable substitution} {
test parseOld-5.12 {empty array name support} {
list [catch {set b a$()} msg] $msg
} {1 {can't read "()": no such variable}}
-catch {unset a}
+unset -nocomplain a
test parseOld-5.13 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set long {This is a very long variable, long enough to cause storage \
allocation to occur in Tcl_ParseVar. If that storage isn't getting \
freed up correctly, then a core leak will occur when this test is \
@@ -211,13 +209,13 @@ test parseOld-5.13 {array variable substitution} {
run. This text is probably beginning to sound like drivel, but I've \
run out of things to say and I need more characters still.}}}
test parseOld-5.14 {array variable substitution} {
- catch {unset a}; catch {unset b}; catch {unset a1}
+ unset -nocomplain a b a1
set a1(22) foo
set a(foo) bar
set b $a($a1(22))
set b
} bar
-catch {unset a}; catch {unset a1}
+unset -nocomplain a a1
test parseOld-7.1 {backslash substitution} {
set a "\a\c\n\]\}"
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index 0fe394e..84c82ce 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -8,10 +8,8 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
set fullPkgPath [makeDirectory pkg]
@@ -45,7 +43,7 @@ proc pkgtest::parseArgs { args } {
set a [lindex $args $iarg]
if {[regexp {^-} $a]} {
lappend options $a
- if {[string compare -load $a] == 0} {
+ if {$a eq "-load"} {
incr iarg
lappend options [lindex $args $iarg]
}
@@ -81,7 +79,7 @@ proc pkgtest::parseIndex { filePath } {
$slave eval {
rename package package_original
proc package { args } {
- if {[string compare [lindex $args 0] ifneeded] == 0} {
+ if {[lindex $args 0] eq "ifneeded"} {
set pkg [lindex $args 1]
set ver [lindex $args 2]
set ::PKGS($pkg:$ver) [lindex $args 3]
@@ -111,9 +109,9 @@ proc pkgtest::parseIndex { filePath } {
foreach k [lsort [array names P]] {
lappend PKGS $k $P($k)
}
- } err]} {
- set ei $::errorInfo
- set ec $::errorCode
+ } err opts]} {
+ set ei [dict get $opts -errorinfo]
+ set ec [dict get $opts -errorcode]
catch {interp delete $slave}
diff --git a/tests/platform.test b/tests/platform.test
index aab7c78..6596975 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -9,10 +9,14 @@
# 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
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+
+namespace eval ::tcl::test::platform {
+ namespace import ::tcltest::testConstraint
+ namespace import ::tcltest::test
+ namespace import ::tcltest::cleanupTests
+
+ variable ::tcl_platform
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -54,7 +58,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
+
+}
+namespace delete ::tcl::test::platform
return
# Local Variables:
diff --git a/tests/reg.test b/tests/reg.test
index a0ea850..e6ce42c 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -1080,6 +1080,84 @@ test reg-33.13 {Bug 1810264 - infinite loop} {
test reg-33.14 {Bug 1810264 - super-expensive expression} nonPortable {
regexp {(x{200}){200}$y} {x}
} 0
+test reg-33.15 {Bug 3603557 - an "in the wild" RE} {
+ lindex [regexp -expanded -about {
+ ^TETRA_MODE_CMD # Message Type
+ ([[:blank:]]+) # Pad
+ (ETS_1_1|ETS_1_2|ETS_2_2) # SystemCode
+ ([[:blank:]]+) # Pad
+ (CONTINUOUS|CARRIER|MCCH|TRAFFIC) # SharingMode
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,2}) # ColourCode
+ ([[:blank:]]+) # Pad
+ (1|2|3|4|6|9|12|18) # TSReservedFrames
+ ([[:blank:]]+) # Pad
+ (PASS|TRUE|FAIL|FALSE) # UPlaneDTX
+ ([[:blank:]]+) # Pad
+ (PASS|TRUE|FAIL|FALSE) # Frame18Extension
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,4}) # MCC
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,5}) # MNC
+ ([[:blank:]]+) # Pad
+ (BOTH|BCAST|ENQRY|NONE) # NbrCellBcast
+ ([[:blank:]]+) # Pad
+ (UNKNOWN|LOW|MEDIUM|HIGH) # CellServiceLevel
+ ([[:blank:]]+) # Pad
+ (PASS|TRUE|FAIL|FALSE) # LateEntryInfo
+ ([[:blank:]]+) # Pad
+ (300|400) # FrequencyBand
+ ([[:blank:]]+) # Pad
+ (NORMAL|REVERSE) # ReverseOperation
+ ([[:blank:]]+) # Pad
+ (NONE|\+6\.25|\-6\.25|\+12\.5) # Offset
+ ([[:blank:]]+) # Pad
+ (10) # DuplexSpacing
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,4}) # MainCarrierNr
+ ([[:blank:]]+) # Pad
+ (0|1|2|3) # NrCSCCH
+ ([[:blank:]]+) # Pad
+ (15|20|25|30|35|40|45) # MSTxPwrMax
+ ([[:blank:]]+) # Pad
+ (\-125|\-120|\-115|\-110|\-105|\-100|\-95|\-90|\-85|\-80|\-75|\-70|\-65|\-60|\-55|\-50)
+ # RxLevAccessMin
+ ([[:blank:]]+) # Pad
+ (\-53|\-51|\-49|\-47|\-45|\-43|\-41|\-39|\-37|\-35|\-33|\-31|\-29|\-27|\-25|\-23)
+ # AccessParameter
+ ([[:blank:]]+) # Pad
+ (DISABLE|[[:digit:]]{3,4}) # RadioDLTimeout
+ ([[:blank:]]+) # Pad
+ (\-[[:digit:]]{2,3}) # RSSIThreshold
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,5}) # CCKIdSCKVerNr
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,5}) # LocationArea
+ ([[:blank:]]+) # Pad
+ ([(1|0)]{16}) # SubscriberClass
+ ([[:blank:]]+) # Pad
+ ([(1|0)]{12}) # BSServiceDetails
+ ([[:blank:]]+) # Pad
+ (RANDOMIZE|IMMEDIATE|[[:digit:]]{1,2}) # IMM
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,2}) # WT
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,2}) # Nu
+ ([[:blank:]]+) # Pad
+ ([0-1]) # FrameLngFctr
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,2}) # TSPtr
+ ([[:blank:]]+) # Pad
+ ([0-7]) # MinPriority
+ ([[:blank:]]+) # Pad
+ (PASS|TRUE|FAIL|FALSE) # ExtdSrvcsEnabled
+ ([[:blank:]]+) # Pad
+ (.*) # ConditionalFields
+ }] 0
+} 68
+test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} {
+ lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0
+} 1
# cleanup
::tcltest::cleanupTests
diff --git a/tests/regexp.test b/tests/regexp.test
index 7cafd1b..1b2bec9 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -819,6 +819,67 @@ test regexp-22.1 {Bug 1810038} {
test regexp-22.2 {regexp compile and backrefs, Bug 1857126} {
regexp -- {([bc])\1} bb
} 1
+test regexp-22.3 {Bug 3604074} {
+ # This will hang in interps where the bug is not fixed
+ regexp ((((((((a)*)*)*)*)*)*)*)* a
+} 1
+test regexp-22.4 {Bug 3606139} -setup {
+ interp alias {} a {} string repeat a
+} -body {
+ # This crashes in interps where the bug is not fixed
+ regexp [join [list [a 160]([a 55])[a 668]([a 55])[a 669]([a 55]) \
+ [a 668]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \
+ [a 672]([a 55])[a 669]([a 55])[a 671]([a 55])[a 671]([a 55]) \
+ [a 672]([a 55])[a 652]([a 55])[a 672]([a 55])[a 671]([a 55]) \
+ [a 671]([a 55])[a 671]([a 55])[a 653]([a 55])[a 672]([a 55]) \
+ [a 653]([a 55])[a 672]([a 55])[a 672]([a 55])[a 652]([a 55]) \
+ [a 671]([a 55])[a 652]([a 55])[a 652]([a 55])[a 672]([a 55]) \
+ [a 672]([a 55])[a 672]([a 55])[a 653]([a 55])[a 671]([a 55]) \
+ [a 669]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \
+ [a 668]([a 55])[a 650]([a 55])[a 650]([a 55])[a 672]([a 55]) \
+ [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
+ [a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \
+ [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 672]([a 55]) \
+ [a 670]([a 55])[a 671]([a 55])[a 672]([a 55])[a 672]([a 55]) \
+ [a 671]([a 55])[a 671]([a 55])[a 672]([a 55])[a 669]([a 55]) \
+ [a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
+ [a 669]([a 55])[a 668]([a 55])[a 669]([a 55])[a 669]([a 55]) \
+ [a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
+ [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 669]([a 55]) \
+ [a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \
+ [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \
+ [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
+ [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
+ [a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 710]([a 55]) \
+ [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
+ [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
+ [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 669]([a 55]) \
+ [a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \
+ [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \
+ [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 668]([a 55]) \
+ [a 667]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \
+ [a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
+ [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \
+ [a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \
+ [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a
+} -cleanup {
+ rename a {}
+} -returnCodes 1 -result {couldn't compile regular expression pattern: nfa has too many states}
+test regexp-22.5 {Bug 3610026} -setup {
+ set e {}
+ set cp 99
+ while {$cp < 32864} {
+ append e [format %c [incr cp]]
+ }
+} -body {
+ regexp -about $e
+} -cleanup {
+ unset -nocomplain e cp
+} -returnCodes error -match glob -result {*too many colors*}
+test regexp-22.6 {Bug 6585b21ca8} {
+ expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"}
+} rogr
+
test regexp-23.1 {regexp -all and -line} {
set string ""
diff --git a/tests/rename.test b/tests/rename.test
index 1fa0441..ebf5425 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -140,6 +140,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel {
if {[info exists env(value)]} {
unset env(value)
}
+test rename-4.8 {Bug a16752c252} testdel {
+ set x broken
+ testdel {} foo {set x ok}
+ proc foo args {}
+ rename foo {}
+ return -level 0 $x[unset x]
+} ok
# Save the unknown procedure which is modified by the following test.
diff --git a/tests/result.test b/tests/result.test
index 3391ce1..9e8a66b 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -10,10 +10,8 @@
# 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::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
diff --git a/tests/safe.test b/tests/safe.test
index 4a2792e..859f352 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -425,6 +425,19 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
+test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup {
+ set i [safe::interpCreate]
+} -body {
+ catch {interp eval $i {load {} Safepkg1}} m o
+ dict get $o -errorinfo
+} -returnCodes ok -cleanup {
+ unset -nocomplain m o
+ safe::interpDelete $i
+} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
+ invoked from within
+"load {} Safepkg1"
+ invoked from within
+"interp eval $i {load {} Safepkg1}"}
test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body {
set i [safe::interpCreate -nostatics]
interp eval $i {load {} Safepkg1}
@@ -444,6 +457,18 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure}
+test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body {
+ set i [safe::interpCreate -nestedloadok]
+ catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o
+ dict get $o -errorinfo
+} -returnCodes ok -cleanup {
+ unset -nocomplain m o
+ safe::interpDelete $i
+} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure
+ invoked from within
+"load {} Safepkg1 x"
+ invoked from within
+"interp eval $i {interp create x; load {} Safepkg1 x}"}
test safe-11.1 {testing safe encoding} -setup {
set i [safe::interpCreate]
@@ -501,6 +526,23 @@ test safe-11.7 {testing safe encoding} -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertfrom ?encoding? data"}
+test safe-11.7.1 {testing safe encoding} -setup {
+ set i [safe::interpCreate]
+} -body {
+ catch {interp eval $i encoding convertfrom} m o
+ dict get $o -errorinfo
+} -returnCodes ok -cleanup {
+ unset -nocomplain m o
+ safe::interpDelete $i
+} -result {wrong # args: should be "encoding convertfrom ?encoding? data"
+ while executing
+"encoding convertfrom"
+ invoked from within
+"::interp invokehidden interp1 encoding convertfrom"
+ invoked from within
+"encoding convertfrom"
+ invoked from within
+"interp eval $i encoding convertfrom"}
test safe-11.8 {testing safe encoding} -setup {
set i [safe::interpCreate]
} -body {
@@ -508,6 +550,23 @@ test safe-11.8 {testing safe encoding} -setup {
} -returnCodes error -cleanup {
safe::interpDelete $i
} -result {wrong # args: should be "encoding convertto ?encoding? data"}
+test safe-11.8.1 {testing safe encoding} -setup {
+ set i [safe::interpCreate]
+} -body {
+ catch {interp eval $i encoding convertto} m o
+ dict get $o -errorinfo
+} -returnCodes ok -cleanup {
+ unset -nocomplain m o
+ safe::interpDelete $i
+} -result {wrong # args: should be "encoding convertto ?encoding? data"
+ while executing
+"encoding convertto"
+ invoked from within
+"::interp invokehidden interp1 encoding convertto"
+ invoked from within
+"encoding convertto"
+ invoked from within
+"interp eval $i encoding convertto"}
test safe-12.1 {glob is restricted [Bug 2906841]} -setup {
set i [safe::interpCreate]
@@ -715,8 +774,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup {
lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
} -cleanup {
+ unset -nocomplain msg
interp delete $i
} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}}
+test safe-15.1.1 {safe file ensemble does not surprise code} -setup {
+ set i [interp create -safe]
+} -body {
+ set result [expr {"file" in [interp hidden $i]}]
+ lappend result [interp eval $i {tcl::file::split a/b/c}]
+ lappend result [catch {interp eval $i {tcl::file::isdirectory .}}]
+ lappend result [interp invokehidden $i file split a/b/c]
+ lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
+ lappend result [catch {interp invokehidden $i file isdirectory .}]
+ interp expose $i file
+ lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
+ lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo]
+} -cleanup {
+ unset -nocomplain msg o
+ interp delete $i
+} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file
+ while executing
+"file isdirectory ."
+ invoked from within
+"interp eval $i {file isdirectory .}"}}
### ~ should have no special meaning in paths in safe interpreters
test safe-16.1 {Bug 3529949: defang ~ in paths} -setup {
diff --git a/tests/scan.test b/tests/scan.test
index 97ad5eb..ea0c500 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -1,8 +1,8 @@
# Commands covered: scan
#
-# 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.
+# 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-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
@@ -11,14 +11,83 @@
# 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} {
+if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
+# procedure that returns the range of integers
+
+proc int_range {} {
+ for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} {
+ set MIN_INT [expr { $MIN_INT << 1 }]
+ }
+ set MIN_INT [expr {int($MIN_INT)}]
+ set MAX_INT [expr { ~ $MIN_INT }]
+ return [list $MIN_INT $MAX_INT]
+}
+
+# Big test for correct ordering of data in [expr]
+
+proc testIEEE {} {
+ variable ieeeValues
+ binary scan [binary format dd -1.0 1.0] c* c
+ switch -exact -- $c {
+ {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
+ # little endian
+ binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
+ ieeeValues(-Infinity)
+ binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
+ ieeeValues(-Normal)
+ binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
+ ieeeValues(-Subnormal)
+ binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
+ ieeeValues(-0)
+ binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(+0)
+ binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
+ ieeeValues(+Subnormal)
+ binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
+ ieeeValues(+Normal)
+ binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
+ ieeeValues(+Infinity)
+ binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
+ ieeeValues(NaN)
+ set ieeeValues(littleEndian) 1
+ return 1
+ }
+ {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
+ binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(-Infinity)
+ binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(-Normal)
+ binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(-Subnormal)
+ binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(-0)
+ binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(+0)
+ binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(+Subnormal)
+ binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(+Normal)
+ binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(+Infinity)
+ binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
+ ieeeValues(NaN)
+ set ieeeValues(littleEndian) 0
+ return 1
+ }
+ default {
+ return 0
+ }
+ }
+}
+
+testConstraint ieeeFloatingPoint [testIEEE]
testConstraint wideIs64bit \
[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
-
+
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
} {1 f}
@@ -43,10 +112,11 @@ test scan-1.7 {BuildCharSet, CharInSet} {
test scan-1.8 {BuildCharSet, CharInSet} {
list [scan def-abc {%[^c-a]} x] $x
} {1 def-}
-test scan-1.9 {BuildCharSet, CharInSet no match} {
- catch {unset x}
+test scan-1.9 {BuildCharSet, CharInSet no match} -setup {
+ unset -nocomplain x
+} -body {
list [scan {= f} {= %[TF]} x] [info exists x]
-} {0 0}
+} -result {0 0}
test scan-2.1 {ReleaseCharSet} {
list [scan abcde {%[abc]} x] $x
@@ -55,53 +125,53 @@ test scan-2.2 {ReleaseCharSet} {
list [scan abcde {%[a-c]} x] $x
} {1 abc}
-test scan-3.1 {ValidateFormat} {
- list [catch {scan {} {%d%1$d} x} msg] $msg
-} {1 {cannot mix "%" and "%n$" conversion specifiers}}
-test scan-3.2 {ValidateFormat} {
- list [catch {scan {} {%d%1$d} x} msg] $msg
-} {1 {cannot mix "%" and "%n$" conversion specifiers}}
-test scan-3.3 {ValidateFormat} {
- list [catch {scan {} {%2$d%d} x} msg] $msg
-} {1 {"%n$" argument index out of range}}
+test scan-3.1 {ValidateFormat} -returnCodes error -body {
+ scan {} {%d%1$d} x
+} -result {cannot mix "%" and "%n$" conversion specifiers}
+test scan-3.2 {ValidateFormat} -returnCodes error -body {
+ scan {} {%d%1$d} x
+} -result {cannot mix "%" and "%n$" conversion specifiers}
+test scan-3.3 {ValidateFormat} -returnCodes error -body {
+ scan {} {%2$d%d} x
+} -result {"%n$" argument index out of range}
test scan-3.4 {ValidateFormat} {
# degenerate case, before changed from 8.2 to 8.3
list [catch {scan {} %d} msg] $msg
} {0 {}}
-test scan-3.5 {ValidateFormat} {
- list [catch {scan {} {%10c} a} msg] $msg
-} {1 {field width may not be specified in %c conversion}}
-test scan-3.6 {ValidateFormat} {
- list [catch {scan {} {%*1$d} a} msg] $msg
-} {1 {bad scan conversion character "$"}}
-test scan-3.7 {ValidateFormat} {
- list [catch {scan {} {%1$d%1$d} a} msg] $msg
-} {1 {variable is assigned by multiple "%n$" conversion specifiers}}
-test scan-3.8 {ValidateFormat} {
- list [catch {scan {} a x} msg] $msg
-} {1 {variable is not assigned by any conversion specifiers}}
-test scan-3.9 {ValidateFormat} {
- list [catch {scan {} {%2$s} x y} msg] $msg
-} {1 {variable is not assigned by any conversion specifiers}}
-test scan-3.10 {ValidateFormat} {
- list [catch {scan {} {%[a} x} msg] $msg
-} {1 {unmatched [ in format string}}
-test scan-3.11 {ValidateFormat} {
- list [catch {scan {} {%[^a} x} msg] $msg
-} {1 {unmatched [ in format string}}
-test scan-3.12 {ValidateFormat} {
- list [catch {scan {} {%[]a} x} msg] $msg
-} {1 {unmatched [ in format string}}
-test scan-3.13 {ValidateFormat} {
- list [catch {scan {} {%[^]a} x} msg] $msg
-} {1 {unmatched [ in format string}}
+test scan-3.5 {ValidateFormat} -returnCodes error -body {
+ scan {} {%10c} a
+} -result {field width may not be specified in %c conversion}
+test scan-3.6 {ValidateFormat} -returnCodes error -body {
+ scan {} {%*1$d} a
+} -result {bad scan conversion character "$"}
+test scan-3.7 {ValidateFormat} -returnCodes error -body {
+ scan {} {%1$d%1$d} a
+} -result {variable is assigned by multiple "%n$" conversion specifiers}
+test scan-3.8 {ValidateFormat} -returnCodes error -body {
+ scan {} a x
+} -result {variable is not assigned by any conversion specifiers}
+test scan-3.9 {ValidateFormat} -returnCodes error -body {
+ scan {} {%2$s} x y
+} -result {variable is not assigned by any conversion specifiers}
+test scan-3.10 {ValidateFormat} -returnCodes error -body {
+ scan {} {%[a} x
+} -result {unmatched [ in format string}
+test scan-3.11 {ValidateFormat} -returnCodes error -body {
+ scan {} {%[^a} x
+} -result {unmatched [ in format string}
+test scan-3.12 {ValidateFormat} -returnCodes error -body {
+ scan {} {%[]a} x
+} -result {unmatched [ in format string}
+test scan-3.13 {ValidateFormat} -returnCodes error -body {
+ scan {} {%[^]a} x
+} -result {unmatched [ in format string}
-test scan-4.1 {Tcl_ScanObjCmd, argument checks} {
- list [catch {scan} msg] $msg
-} {1 {wrong # args: should be "scan string format ?varName ...?"}}
-test scan-4.2 {Tcl_ScanObjCmd, argument checks} {
- list [catch {scan string} msg] $msg
-} {1 {wrong # args: should be "scan string format ?varName ...?"}}
+test scan-4.1 {Tcl_ScanObjCmd, argument checks} -returnCodes error -body {
+ scan
+} -result {wrong # args: should be "scan string format ?varName ...?"}
+test scan-4.2 {Tcl_ScanObjCmd, argument checks} -returnCodes error -body {
+ scan string
+} -result {wrong # args: should be "scan string format ?varName ...?"}
test scan-4.3 {Tcl_ScanObjCmd, argument checks} {
# degenerate case, before changed from 8.2 to 8.3
list [catch {scan string format} msg] $msg
@@ -191,93 +261,114 @@ test scan-4.29 {Tcl_ScanObjCmd, character scanning} {
list [scan {abcdef} {%*c%n} x] $x
} {1 1}
-test scan-4.30 {Tcl_ScanObjCmd, base-10 integer scanning} {
+test scan-4.30 {Tcl_ScanObjCmd, base-10 integer scanning} -setup {
set x {}
+} -body {
list [scan {1234567890a} {%3d} x] $x
-} {1 123}
-test scan-4.31 {Tcl_ScanObjCmd, base-10 integer scanning} {
+} -result {1 123}
+test scan-4.31 {Tcl_ScanObjCmd, base-10 integer scanning} -setup {
set x {}
+} -body {
list [scan {1234567890a} {%d} x] $x
-} {1 1234567890}
-test scan-4.32 {Tcl_ScanObjCmd, base-10 integer scanning} {
+} -result {1 1234567890}
+test scan-4.32 {Tcl_ScanObjCmd, base-10 integer scanning} -setup {
set x {}
+} -body {
list [scan {01234567890a} {%d} x] $x
-} {1 1234567890}
-test scan-4.33 {Tcl_ScanObjCmd, base-10 integer scanning} {
+} -result {1 1234567890}
+test scan-4.33 {Tcl_ScanObjCmd, base-10 integer scanning} -setup {
set x {}
+} -body {
list [scan {+01234} {%d} x] $x
-} {1 1234}
-test scan-4.34 {Tcl_ScanObjCmd, base-10 integer scanning} {
+} -result {1 1234}
+test scan-4.34 {Tcl_ScanObjCmd, base-10 integer scanning} -setup {
set x {}
+} -body {
list [scan {-01234} {%d} x] $x
-} {1 -1234}
-test scan-4.35 {Tcl_ScanObjCmd, base-10 integer scanning} {
+} -result {1 -1234}
+test scan-4.35 {Tcl_ScanObjCmd, base-10 integer scanning} -setup {
set x {}
+} -body {
list [scan {a01234} {%d} x] $x
-} {0 {}}
-test scan-4.36 {Tcl_ScanObjCmd, base-10 integer scanning} {
+} -result {0 {}}
+test scan-4.36 {Tcl_ScanObjCmd, base-10 integer scanning} -setup {
set x {}
+} -body {
list [scan {0x10} {%d} x] $x
-} {1 0}
-test scan-4.37 {Tcl_ScanObjCmd, base-8 integer scanning} {
+} -result {1 0}
+test scan-4.37 {Tcl_ScanObjCmd, base-8 integer scanning} -setup {
set x {}
+} -body {
list [scan {012345678} {%o} x] $x
-} {1 342391}
-test scan-4.38 {Tcl_ScanObjCmd, base-8 integer scanning} {
+} -result {1 342391}
+test scan-4.38 {Tcl_ScanObjCmd, base-8 integer scanning} -setup {
set x {}
+} -body {
list [scan {+1238 -1239 123a} {%o%*s%o%*s%o} x y z] $x $y $z
-} {3 83 -83 83}
-test scan-4.39 {Tcl_ScanObjCmd, base-16 integer scanning} {
+} -result {3 83 -83 83}
+test scan-4.39 {Tcl_ScanObjCmd, base-16 integer scanning} -setup {
set x {}
+} -body {
list [scan {+1238 -123a 0123} {%x%x%x} x y z] $x $y $z
-} {3 4664 -4666 291}
-test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} {
+} -result {3 4664 -4666 291}
+test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} -setup {
+ set x {}
+} -body {
# The behavior changed in 8.4a4/8.3.4cvs (6 Feb) to correctly
# return '1' for 0x1 scanned via %x, to comply with 8.0 and C scanf.
# Bug #495213
- set x {}
list [scan {aBcDeF AbCdEf 0x1} {%x%x%x} x y z] $x $y $z
-} {3 11259375 11259375 1}
-test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} {
+} -result {3 11259375 11259375 1}
+test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} -setup {
set x {}
+} -body {
list [scan {0xF 0x00A0B 0X0XF} {%x %x %x} x y z] $x $y $z
-} {3 15 2571 0}
-test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} {
- catch {unset x}
+} -result {3 15 2571 0}
+test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} -setup {
+ unset -nocomplain x
+} -body {
list [scan {xF} {%x} x] [info exists x]
-} {0 0}
-test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} {
+} -result {0 0}
+test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} -setup {
set x {}
+} -body {
list [scan {1001 0b101 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} {%b %b %llb} x y z] $x $y $z
-} {3 9 5 340282366920938463463374607431768211456}
-test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} {
+} -result {3 9 5 340282366920938463463374607431768211456}
+test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} -setup {
set x {}
+} -body {
list [scan {10 010 0x10 0b10} {%i%i%i%i} x y z t] $x $y $z $t
-} {4 10 8 16 0}
-test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} {
+} -result {4 10 8 16 0}
+test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} -setup {
set x {}
+} -body {
list [scan {10 010 0X10} {%i%i%i} x y z] $x $y $z
-} {3 10 8 16}
-test scan-4.43 {Tcl_ScanObjCmd, integer scanning, odd cases} {
+} -result {3 10 8 16}
+test scan-4.43 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup {
set x {}
+} -body {
list [scan {+ } {%i} x] $x
-} {0 {}}
-test scan-4.44 {Tcl_ScanObjCmd, integer scanning, odd cases} {
+} -result {0 {}}
+test scan-4.44 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup {
set x {}
+} -body {
list [scan {+} {%i} x] $x
-} {-1 {}}
-test scan-4.45 {Tcl_ScanObjCmd, integer scanning, odd cases} {
+} -result {-1 {}}
+test scan-4.45 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup {
set x {}
+} -body {
list [scan {0x} {%i%s} x y] $x $y
-} {2 0 x}
-test scan-4.46 {Tcl_ScanObjCmd, integer scanning, odd cases} {
+} -result {2 0 x}
+test scan-4.46 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup {
set x {}
+} -body {
list [scan {0X} {%i%s} x y] $x $y
-} {2 0 X}
-test scan-4.47 {Tcl_ScanObjCmd, integer scanning, suppressed} {
+} -result {2 0 X}
+test scan-4.47 {Tcl_ScanObjCmd, integer scanning, suppressed} -setup {
set x {}
+} -body {
list [scan {123def} {%*i%s} x] $x
-} {1 def}
+} -result {1 def}
test scan-4.48 {Tcl_ScanObjCmd, float scanning} {
list [scan {1 2 3} {%e %f %g} x y z] $x $y $z
} {3 1.0 2.0 3.0}
@@ -299,133 +390,134 @@ test scan-4.53 {Tcl_ScanObjCmd, float scanning} {
test scan-4.54 {Tcl_ScanObjCmd, float scanning} {
list [scan {1.0e-1} %f x] $x
} {1 0.1}
-test scan-4.55 {Tcl_ScanObjCmd, odd cases} {
+test scan-4.55 {Tcl_ScanObjCmd, odd cases} -setup {
set x {}
+} -body {
list [scan {+} %f x] $x
-} {-1 {}}
-test scan-4.56 {Tcl_ScanObjCmd, odd cases} {
+} -result {-1 {}}
+test scan-4.56 {Tcl_ScanObjCmd, odd cases} -setup {
set x {}
+} -body {
list [scan {1.0e} %f%s x y] $x $y
-} {2 1.0 e}
-test scan-4.57 {Tcl_ScanObjCmd, odd cases} {
+} -result {2 1.0 e}
+test scan-4.57 {Tcl_ScanObjCmd, odd cases} -setup {
set x {}
+} -body {
list [scan {1.0e+} %f%s x y] $x $y
-} {2 1.0 e+}
-test scan-4.58 {Tcl_ScanObjCmd, odd cases} {
+} -result {2 1.0 e+}
+test scan-4.58 {Tcl_ScanObjCmd, odd cases} -setup {
set x {}
set y {}
+} -body {
list [scan {e1} %f%s x y] $x $y
-} {0 {} {}}
+} -result {0 {} {}}
test scan-4.59 {Tcl_ScanObjCmd, float scanning} {
list [scan {1.0e-1x} %*f%n x] $x
} {1 6}
-test scan-4.60 {Tcl_ScanObjCmd, set errors} {
+test scan-4.60 {Tcl_ScanObjCmd, set errors} -setup {
set x {}
set y {}
- catch {unset z}; array set z {}
- set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \
- $msg $x $y]
- unset z
- set result
-} {1 {can't set "z": variable is array} abc ghi}
-test scan-4.61 {Tcl_ScanObjCmd, set errors} {
+ unset -nocomplain z
+} -body {
+ array set z {}
+ list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] $msg $x $y
+} -cleanup {
+ unset -nocomplain z
+} -result {1 {can't set "z": variable is array} abc ghi}
+test scan-4.61 {Tcl_ScanObjCmd, set errors} -setup {
set x {}
- catch {unset y}; array set y {}
- catch {unset z}; array set z {}
- set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \
- $msg $x]
- unset y
- unset z
- set result
-} {1 {can't set "z": variable is array} abc}
-
-# procedure that returns the range of integers
-
-proc int_range {} {
- for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} {
- set MIN_INT [expr { $MIN_INT << 1 }]
- }
- set MIN_INT [expr {int($MIN_INT)}]
- set MAX_INT [expr { ~ $MIN_INT }]
- return [list $MIN_INT $MAX_INT]
-}
+ unset -nocomplain y
+ unset -nocomplain z
+} -body {
+ array set y {}
+ array set z {}
+ list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] $msg $x
+} -cleanup {
+ unset -nocomplain y
+ unset -nocomplain z
+} -result {1 {can't set "z": variable is array} abc}
test scan-4.62 {scanning of large and negative octal integers} {
- foreach { MIN_INT MAX_INT } [int_range] {}
+ lassign [int_range] MIN_INT MAX_INT
set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT]
list [scan $scanstring {%o %o %o} a b c] \
[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
test scan-4.63 {scanning of large and negative hex integers} {
- foreach { MIN_INT MAX_INT } [int_range] {}
+ lassign [int_range] MIN_INT MAX_INT
set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT]
list [scan $scanstring {%x %x %x} a b c] \
[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
} {3 1 1 1}
-# clean up from last two tests
-
-catch {
- rename int_range {}
-}
-
-test scan-5.1 {integer scanning} {
+test scan-5.1 {integer scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d
-} {4 -20 1476 33 0}
-test scan-5.2 {integer scanning} {
+} -result {4 -20 1476 33 0}
+test scan-5.2 {integer scanning} -setup {
set a {}; set b {}; set c {}
+} -body {
list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c
-} {3 -4 16 7890}
-test scan-5.3 {integer scanning} {
+} -result {3 -4 16 7890}
+test scan-5.3 {integer scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d
-} {4 -45 16 10 987}
-test scan-5.4 {integer scanning} {
+} -result {4 -45 16 10 987}
+test scan-5.4 {integer scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d
-} {4 14 427 50 16}
-test scan-5.5 {integer scanning} {
+} -result {4 14 427 50 16}
+test scan-5.5 {integer scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \
$a $b $c $d
-} {4 2739128 342391 561323 52719}
-test scan-5.6 {integer scanning} {
+} -result {4 2739128 342391 561323 52719}
+test scan-5.6 {integer scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d
-} {4 171 291 -20 52}
-test scan-5.7 {integer scanning} {
+} -result {4 171 291 -20 52}
+test scan-5.7 {integer scanning} -setup {
set a {}; set b {}
+} -body {
list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b
-} {2 17767 375}
-test scan-5.8 {integer scanning} {
+} -result {2 17767 375}
+test scan-5.8 {integer scanning} -setup {
set a {}; set b {}
+} -body {
list [scan "a 1234" "%d %d" a b] $a $b
-} {0 {} {}}
-test scan-5.9 {integer scanning} {
- set a {}; set b {}; set c {}; set d {};
+} -result {0 {} {}}
+test scan-5.9 {integer scanning} -setup {
+ set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d
-} {4 12 34 56 78}
-test scan-5.10 {integer scanning} {
+} -result {4 12 34 56 78}
+test scan-5.10 {integer scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d
-} {2 1 2 {} {}}
+} -result {2 1 2 {} {}}
#
-# The behavior for scaning intergers larger than MAX_INT is
-# not defined by the ANSI spec. Some implementations wrap the
-# input (-16) some return MAX_INT.
+# The behavior for scaning intergers larger than MAX_INT is not defined by the
+# ANSI spec. Some implementations wrap the input (-16) some return MAX_INT.
#
-test scan-5.11 {integer scanning} {nonPortable} {
- set a {}; set b {};
+test scan-5.11 {integer scanning} -constraints {nonPortable} -setup {
+ set a {}; set b {}
+} -body {
list [scan "4294967280 4294967280" "%u %d" a b] $a \
[expr {$b == -16 || $b == 0x7fffffff}]
-} {2 4294967280 1}
-test scan-5.12 {integer scanning} {wideIs64bit} {
+} -result {2 4294967280 1}
+test scan-5.12 {integer scanning} -constraints {wideIs64bit} -setup {
set a {}; set b {}; set c {}
+} -body {
list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \
%ld,%lx,%lo a b c] $a $b $c
-} {3 7810179016327718216 7810179016327718216 7810179016327718216}
+} -result {3 7810179016327718216 7810179016327718216 7810179016327718216}
test scan-5.13 {integer scanning and overflow} {
# This test used to fail on some 64-bit systems. [Bug 1011860]
scan {300000000 3000000000 30000000000} {%ld %ld %ld}
@@ -435,153 +527,184 @@ test scan-5.14 {integer scanning} {
scan 0xff %u
} 0
-test scan-6.1 {floating-point scanning} {
+test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
-} {3 2.1 -300000000.0 0.99962 {}}
-test scan-6.2 {floating-point scanning} {
+} -result {3 2.1 -300000000.0 0.99962 {}}
+test scan-6.2 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d
-} {4 -1.0 234.0 5.0 8.2}
-test scan-6.3 {floating-point scanning} {
+} -result {4 -1.0 234.0 5.0 8.2}
+test scan-6.3 {floating-point scanning} -setup {
set a {}; set b {}; set c {}
+} -body {
list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c
-} {3 10000.0 30000.0}
+} -result {3 10000.0 30000.0}
#
-# Some libc implementations consider 3.e- bad input. The ANSI
-# spec states that digits must follow the - sign.
+# Some libc implementations consider 3.e- bad input. The ANSI spec states
+# that digits must follow the - sign.
#
-test scan-6.4 {floating-point scanning} {
+test scan-6.4 {floating-point scanning} -setup {
set a {}; set b {}; set c {}
+} -body {
list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c
-} {3 1.0 200.0 3.0}
-test scan-6.5 {floating-point scanning} {
+} -result {3 1.0 200.0 3.0}
+test scan-6.5 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d
-} {4 4.6 99999.7 87.643 118.0}
-test scan-6.6 {floating-point scanning} {
+} -result {4 4.6 99999.7 87.643 118.0}
+test scan-6.6 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d
-} {4 1.2345 0.697 124.0 5e-5}
-test scan-6.7 {floating-point scanning} {
+} -result {4 1.2345 0.697 124.0 5e-5}
+test scan-6.7 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
-} {1 4.6 {} {} {}}
-test scan-6.8 {floating-point scanning} {
+} -result {1 4.6 {} {} {}}
+test scan-6.8 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
-} {2 4.6 5.2 {} {}}
+} -result {2 4.6 5.2 {} {}}
-test scan-7.1 {string and character scanning} {
+test scan-7.1 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
-} {4 abc def ghijk dum}
-test scan-7.2 {string and character scanning} {
+} -result {4 abc def ghijk dum}
+test scan-7.2 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d
-} {4 97 32 b cdef}
-test scan-7.3 {string and character scanning} {
+} -result {4 97 32 b cdef}
+test scan-7.3 {string and character scanning} -setup {
set a {}; set b {}; set c {}
+} -body {
list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c
-} {1 test {} {}}
-test scan-7.4 {string and character scanning} {
- set a {}; set b {}; set c {}; set d
+} -result {1 test {} {}}
+test scan-7.4 {string and character scanning} -setup {
+ set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d
-} {4 abab cd {01234 } {f 12345}}
-test scan-7.5 {string and character scanning} {
+} -result {4 abab cd {01234 } {f 12345}}
+test scan-7.5 {string and character scanning} -setup {
set a {}; set b {}; set c {}
+} -body {
list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c
-} {3 aabc bcdefg 43}
-test scan-7.6 {string and character scanning, unicode} {
+} -result {3 aabc bcdefg 43}
+test scan-7.6 {string and character scanning, unicode} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
-} "4 abc d\u00c7f ghijk dum"
-test scan-7.7 {string and character scanning, unicode} {
+} -result "4 abc d\u00c7f ghijk dum"
+test scan-7.7 {string and character scanning, unicode} -setup {
set a {}; set b {}
+} -body {
list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b
-} "2 199 99"
-test scan-7.8 {string and character scanning, unicode} {
+} -result "2 199 99"
+test scan-7.8 {string and character scanning, unicode} -setup {
set a {}; set b {}
+} -body {
list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a
-} "1 ab\ufeff"
+} -result "1 ab\ufeff"
-test scan-8.1 {error conditions} {
- catch {scan a}
-} 1
-test scan-8.2 {error conditions} {
- catch {scan a} msg
- set msg
-} {wrong # args: should be "scan string format ?varName ...?"}
-test scan-8.3 {error conditions} {
- list [catch {scan a %D x} msg] $msg
-} {1 {bad scan conversion character "D"}}
-test scan-8.4 {error conditions} {
- list [catch {scan a %O x} msg] $msg
-} {1 {bad scan conversion character "O"}}
-test scan-8.5 {error conditions} {
- list [catch {scan a %X x} msg] $msg
-} {1 {bad scan conversion character "X"}}
-test scan-8.6 {error conditions} {
- list [catch {scan a %F x} msg] $msg
-} {1 {bad scan conversion character "F"}}
-test scan-8.7 {error conditions} {
- list [catch {scan a %E x} msg] $msg
-} {1 {bad scan conversion character "E"}}
-test scan-8.8 {error conditions} {
- list [catch {scan a "%d %d" a} msg] $msg
-} {1 {different numbers of variable names and field specifiers}}
-test scan-8.9 {error conditions} {
- list [catch {scan a "%d %d" a b c} msg] $msg
-} {1 {variable is not assigned by any conversion specifiers}}
-test scan-8.10 {error conditions} {
+test scan-8.1 {error conditions} -body {
+ scan a
+} -returnCodes error -match glob -result *
+test scan-8.2 {error conditions} -returnCodes error -body {
+ scan a
+} -result {wrong # args: should be "scan string format ?varName ...?"}
+test scan-8.3 {error conditions} -returnCodes error -body {
+ scan a %D x
+} -result {bad scan conversion character "D"}
+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"}
+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"}
+test scan-8.8 {error conditions} -returnCodes error -body {
+ scan a "%d %d" a
+} -result {different numbers of variable names and field specifiers}
+test scan-8.9 {error conditions} -returnCodes error -body {
+ scan a "%d %d" a b c
+} -result {variable is not assigned by any conversion specifiers}
+test scan-8.10 {error conditions} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d
-} {1 {} {} {} {}}
-test scan-8.11 {error conditions} {
+} -result {1 {} {} {} {}}
+test scan-8.11 {error conditions} -setup {
set a {}; set b {}; set c {}; set d {}
+} -body {
list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d
-} {2 1 2 {} {}}
-test scan-8.12 {error conditions} {
- catch {unset a}
+} -result {2 1 2 {} {}}
+test scan-8.12 {error conditions} -setup {
+ unset -nocomplain a
+} -body {
set a(0) 44
- list [catch {scan 44 %d a} msg] $msg
-} {1 {can't set "a": variable is array}}
-test scan-8.13 {error conditions} {
- catch {unset a}
+ scan 44 %d a
+} -returnCodes error -cleanup {
+ unset -nocomplain a
+} -result {can't set "a": variable is array}
+test scan-8.13 {error conditions} -setup {
+ unset -nocomplain a
+} -body {
set a(0) 44
- list [catch {scan 44 %c a} msg] $msg
-} {1 {can't set "a": variable is array}}
-test scan-8.14 {error conditions} {
- catch {unset a}
+ scan 44 %c a
+} -returnCodes error -cleanup {
+ unset -nocomplain a
+} -result {can't set "a": variable is array}
+test scan-8.14 {error conditions} -setup {
+ unset -nocomplain a
+} -body {
set a(0) 44
- list [catch {scan 44 %s a} msg] $msg
-} {1 {can't set "a": variable is array}}
-test scan-8.15 {error conditions} {
- catch {unset a}
+ scan 44 %s a
+} -returnCodes error -cleanup {
+ unset -nocomplain a
+} -result {can't set "a": variable is array}
+test scan-8.15 {error conditions} -setup {
+ unset -nocomplain a
+} -body {
set a(0) 44
- list [catch {scan 44 %f a} msg] $msg
-} {1 {can't set "a": variable is array}}
-test scan-8.16 {error conditions} {
- catch {unset a}
+ scan 44 %f a
+} -returnCodes error -cleanup {
+ unset -nocomplain a
+} -result {can't set "a": variable is array}
+test scan-8.16 {error conditions} -setup {
+ unset -nocomplain a
+} -body {
set a(0) 44
- list [catch {scan 44 %f a} msg] $msg
-} {1 {can't set "a": variable is array}}
-catch {unset a}
-test scan-8.17 {error conditions} {
- list [catch {scan 44 %2c a} msg] $msg
-} {1 {field width may not be specified in %c conversion}}
-test scan-8.18 {error conditions} {
- list [catch {scan abc {%[} x} msg] $msg
-} {1 {unmatched [ in format string}}
-test scan-8.19 {error conditions} {
- list [catch {scan abc {%[^a} x} msg] $msg
-} {1 {unmatched [ in format string}}
-test scan-8.20 {error conditions} {
- list [catch {scan abc {%[^]a} x} msg] $msg
-} {1 {unmatched [ in format string}}
-test scan-8.21 {error conditions} {
- list [catch {scan abc {%[]a} x} msg] $msg
-} {1 {unmatched [ in format string}}
+ scan 44 %f a
+} -returnCodes error -cleanup {
+ unset -nocomplain a
+} -result {can't set "a": variable is array}
+test scan-8.17 {error conditions} -returnCodes error -body {
+ scan 44 %2c a
+} -result {field width may not be specified in %c conversion}
+test scan-8.18 {error conditions} -returnCodes error -body {
+ scan abc {%[} x
+} -result {unmatched [ in format string}
+test scan-8.19 {error conditions} -returnCodes error -body {
+ scan abc {%[^a} x
+} -result {unmatched [ in format string}
+test scan-8.20 {error conditions} -returnCodes error -body {
+ scan abc {%[^]a} x
+} -result {unmatched [ in format string}
+test scan-8.21 {error conditions} -returnCodes error -body {
+ scan abc {%[]a} x
+} -result {unmatched [ in format string}
test scan-9.1 {lots of arguments} {
scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20
@@ -591,27 +714,32 @@ test scan-9.2 {lots of arguments} {
set a20
} 200
-test scan-10.1 {miscellaneous tests} {
+test scan-10.1 {miscellaneous tests} -setup {
set a {}
+} -body {
list [scan ab16c ab%dc a] $a
-} {1 16}
-test scan-10.2 {miscellaneous tests} {
+} -result {1 16}
+test scan-10.2 {miscellaneous tests} -setup {
set a {}
+} -body {
list [scan ax16c ab%dc a] $a
-} {0 {}}
-test scan-10.3 {miscellaneous tests} {
+} -result {0 {}}
+test scan-10.3 {miscellaneous tests} -setup {
set a {}
+} -body {
list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a
-} {0 1 114}
-test scan-10.4 {miscellaneous tests} {
+} -result {0 1 114}
+test scan-10.4 {miscellaneous tests} -setup {
set a {}
+} -body {
list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a
-} {0 1 14}
-test scan-10.5 {miscellaneous tests} {
- catch {unset arr}
+} -result {0 1 14}
+test scan-10.5 {miscellaneous tests} -setup {
+ unset -nocomplain arr
+} -body {
set arr(2) {}
list [catch {scan ab%c14 ab%%c%d arr(2)} msg] $msg $arr(2)
-} {0 1 14}
+} -result {0 1 14}
test scan-10.6 {miscellaneous tests} {
scan 5a {%i%[a]}
} {5 a}
@@ -671,9 +799,9 @@ test scan-13.1 {Tcl_ScanObjCmd, inline XPG case} {
test scan-13.2 {Tcl_ScanObjCmd, inline XPG case} {
scan abc {%1$c%2$c%3$c%4$c}
} {97 98 99 {}}
-test scan-13.3 {Tcl_ScanObjCmd, inline XPG case} {
- list [catch {scan abc {%1$c%1$c}} msg] $msg
-} {1 {variable is assigned by multiple "%n$" conversion specifiers}}
+test scan-13.3 {Tcl_ScanObjCmd, inline XPG case} -returnCodes error -body {
+ scan abc {%1$c%1$c}
+} -result {variable is assigned by multiple "%n$" conversion specifiers}
test scan-13.4 {Tcl_ScanObjCmd, inline XPG case} {
scan abc {%2$s%1$c}
} {{} abc}
@@ -692,77 +820,20 @@ test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} {
list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199]
} {200 10 20 30}
-# Big test for correct ordering of data in [expr]
-
-proc testIEEE {} {
- variable ieeeValues
- binary scan [binary format dd -1.0 1.0] c* c
- switch -exact -- $c {
- {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
- # little endian
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \
- ieeeValues(-Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \
- ieeeValues(-Normal)
- binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \
- ieeeValues(-Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \
- ieeeValues(-0)
- binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(+0)
- binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \
- ieeeValues(+Subnormal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \
- ieeeValues(+Normal)
- binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \
- ieeeValues(+Infinity)
- binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \
- ieeeValues(NaN)
- set ieeeValues(littleEndian) 1
- return 1
- }
- {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} {
- binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(-Infinity)
- binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(-Normal)
- binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(-Subnormal)
- binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(-0)
- binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(+0)
- binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(+Subnormal)
- binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(+Normal)
- binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(+Infinity)
- binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \
- ieeeValues(NaN)
- set ieeeValues(littleEndian) 0
- return 1
- }
- default {
- return 0
- }
- }
-}
-
-testConstraint ieeeFloatingPoint [testIEEE]
-
# scan infinities - not working
-test scan-14.1 {infinity} {
+test scan-14.1 {positive infinity} {
scan Inf %g d
- set d
+ return $d
} Inf
-test scan-14.2 {infinity} {
+test scan-14.2 {negative infinity} {
scan -Inf %g d
- set d
+ return $d
} -Inf
# TODO - also need to scan NaN's
+
+catch {rename int_range {}}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/set-old.test b/tests/set-old.test
index 52dc0ff..4c25ec5 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -678,6 +678,11 @@ test set-old-8.57 {array command, array get with trivial pattern} {
set a(y) 2
array get a x
} {x 1}
+test set-old-8.58 {array command, array set with LVT and odd length literal} {
+ list [catch {apply {{} {
+ array set a {b c d}
+ }}} msg] $msg
+} {1 {list must have an even number of elements}}
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
diff --git a/tests/set.test b/tests/set.test
index 1d88553..18119f5 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -524,6 +524,11 @@ test set-5.1 {error on malformed array name} testset2 {
list $msg $msg1
} {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}}
+# In a mem-debug build, this test will crash unless Bug 3602706 is fixed.
+test set-5.2 {Bug 3602706} -body {
+ testset2 ::tcl_platform not-in-there
+} -returnCodes error -result * -match glob
+
# cleanup
catch {unset a}
catch {unset b}
diff --git a/tests/stack.test b/tests/stack.test
index 873cb08..13bc524 100644
--- a/tests/stack.test
+++ b/tests/stack.test
@@ -9,10 +9,8 @@
# 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::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
# Note that a failure in this test may result in a crash of the executable.
diff --git a/tests/string.test b/tests/string.test
index f558d30..740cdc6 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -408,13 +408,15 @@ test string-6.35 {string is double, false} {
test string-6.36 {string is double, false} {
list [string is double -fail var "\n"] $var
} {0 0}
-test string-6.37 {string is double, false on int overflow} {
+test string-6.37 {string is double, false on int overflow} -setup {
+ set var priorValue
+} -body {
# Make it the largest int recognizable, with one more digit for overflow
# Since bignums arrived in Tcl 8.5, the sense of this test changed.
# Now integer values that exceed native limits become bignums, and
# bignums can convert to doubles without error.
list [string is double -fail var [largest_int]0] $var
-} {1 0}
+} -result {1 priorValue}
# string-6.38 removed, underflow on input is no longer an error.
test string-6.39 {string is double, false} {
# This test is non-portable because IRIX thinks
diff --git a/tests/subst.test b/tests/subst.test
index 4be4798..7466895 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup {
} -cleanup {
removeFile subst13.tcl
}
+test subst-13.2 {Test for segfault} -body {
+ subst {[}
+} -returnCodes error -result * -match glob
+
# cleanup
::tcltest::cleanupTests
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 86aca6f..ce8d617 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -80,10 +80,7 @@ proc slave {msgVar args} {
# Need to capture output in msg
- set code [catch {i eval {source $argv0}} foo]
-if $code {
-#puts "$code: $foo\n$::errorInfo"
-}
+ set code [catch {i eval {source $argv0}}]
i eval {close $tcltest::outputChannel}
interp delete [namespace current]::i
set f [open $of]
@@ -99,8 +96,6 @@ if $code {
append msg \n$err
}
return $code
-
-# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg]
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
set result [slave msg test.tcl]
@@ -549,7 +544,7 @@ set notWriteableDir [file join [temporaryDirectory] notwriteable]
makeDirectory notreadable
makeDirectory notwriteable
switch -- $::tcl_platform(platform) {
- "unix" {
+ unix {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
@@ -716,8 +711,8 @@ test tcltest-8.60 {::workingDirectory} {
# clean up from directory testing
-switch $::tcl_platform(platform) {
- "unix" {
+switch -- $::tcl_platform(platform) {
+ unix {
file attributes $notReadableDir -permissions 777
file attributes $notWriteableDir -permissions 777
}
@@ -727,7 +722,7 @@ switch $::tcl_platform(platform) {
}
}
-file delete -force $notReadableDir $notWriteableDir
+file delete -force -- $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory
@@ -1150,7 +1145,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
} -cleanup {
interp delete slave2
interp delete slave1
- if {$oldoptions == "none"} {
+ if {$oldoptions eq "none"} {
unset ::env(TCLTEST_OPTIONS)
} else {
set ::env(TCLTEST_OPTIONS) $oldoptions
diff --git a/tests/thread.test b/tests/thread.test
index d79f693..f32ef61 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -84,28 +84,6 @@ if {[testConstraint testthread]} {
}
testthread errorproc ThreadError
-
- set mainThread [testthread id]
-
- proc ThreadNullError {id info} {
- # ignore
- }
-
- proc threadReap {} {
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != [testthread id]} {
- catch {
- testthread send -async $tid {testthread exit}
- }
- }
- }
- after 1
- }
- testthread errorproc ThreadError
- return [llength [testthread names]]
- }
}
# Some tests require manual draining of the event queue
diff --git a/tests/tm.test b/tests/tm.test
index 149a65d..1b22f8c 100644
--- a/tests/tm.test
+++ b/tests/tm.test
@@ -200,7 +200,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup {
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
- foreach {major minor} [split [info tclversion] .] break
+ lassign [split [package present Tcl] .] major minor
set results {}
set base [file join $base tcl$major]
lappend results [file join $base site-tcl]
diff --git a/tests/trace.test b/tests/trace.test
index 0f48dcf..d830f3c 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -11,10 +11,8 @@
# 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
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -32,15 +30,15 @@ proc getbytes {} {
proc traceScalar {name1 name2 op} {
global info
- set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
+ set info [list $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg]
}
proc traceScalarAppend {name1 name2 op} {
global info
- lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg
+ lappend info $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg
}
proc traceArray {name1 name2 op} {
global info
- set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
+ set info [list $name1 $name2 $op [catch {uplevel 1 set [set name1]($name2)} msg] $msg]
}
proc traceArray2 {name1 name2 op} {
global info
@@ -62,7 +60,7 @@ proc traceCheck {cmd args} {
set info [list [catch $cmd msg] $msg]
}
proc traceCrtElement {value name1 name2 op} {
- uplevel set ${name1}($name2) $value
+ uplevel 1 set ${name1}($name2) $value
}
proc traceCommand {oldName newName op} {
global info
@@ -72,10 +70,10 @@ proc traceCommand {oldName newName op} {
test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
# You may need Purify or Electric Fence to reliably
# see this one fail.
- catch {unset z}
+ unset -nocomplain z
trace add variable z array {set z(foo) 1 ;#}
set res "names: [array names z]"
- catch {unset ::z}
+ unset -nocomplain ::z
trace variable ::z w {unset ::z; error "memory corruption";#}
list [catch {set ::z 1} msg] $msg
} {1 {can't set "::z": memory corruption}}
@@ -83,40 +81,40 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
# Read-tracing on variables
test trace-1.1 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalar
list [catch {set x} msg] $msg $info
} {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}}
test trace-1.2 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x read traceScalar
list [catch {set x} msg] $msg $info
} {0 123 {x {} read 0 123}}
test trace-1.3 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalar
set x 123
set info
} {}
test trace-1.4 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(2) read traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}}
test trace-1.5 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
set info {}
trace add variable x(2) read traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.6 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceArray2
proc p {} {
@@ -127,7 +125,7 @@ test trace-1.6 {trace array element reads} {
list [catch {p} msg] $msg $info
} {0 willi {x 2 read}}
test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read q
proc q {name1 name2 op} {
@@ -144,20 +142,20 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista
list [catch {p} msg] $msg $info
} {0 wolf {x Y read}}
test trace-1.8 {trace reads on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such variable} {}}
test trace-1.9 {trace reads on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
set info {}
trace add variable x read traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.10 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set x 444
set info {}
trace add variable x read traceScalar
@@ -165,28 +163,28 @@ test trace-1.10 {trace variable reads} {
set info
} {}
test trace-1.11 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {set x(foo) 1 ;#}
trace variable x r {unset -nocomplain x(bar) ;#}
array get x
} {}
test trace-1.12 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {unset -nocomplain x(bar) ;#}
trace variable x r {set x(foo) 1 ;#}
array get x
} {}
test trace-1.13 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {set x(foo) 1 ;#}
trace variable x r {unset -nocomplain x;#}
list [catch {array get x} res] $res
} {1 {can't read "x(bar)": no such variable}}
test trace-1.14 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {unset -nocomplain x;#}
trace variable x r {set x(foo) 1 ;#}
@@ -196,28 +194,28 @@ test trace-1.14 {read traces that modify the array structure} {
# Basic write-tracing on variables
test trace-2.1 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceScalar
set x 123
set info
} {x {} write 0 123}
test trace-2.2 {trace writes to array elements} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(33) write traceArray
set x(33) 444
set info
} {x 33 write 0 444}
test trace-2.3 {trace writes on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceArray
set x(abc) qq
set info
} {x abc write 0 qq}
test trace-2.4 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x write traceScalar
@@ -225,7 +223,7 @@ test trace-2.4 {trace variable writes} {
set info
} {}
test trace-2.5 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x write traceScalar
@@ -238,7 +236,7 @@ test trace-2.6 {trace variable writes on compiled local} {
# arrays [Bug 1770591]. The corresponding function for read traces is
# already indirectly tested in trace-1.7
#
- catch {unset x}
+ unset -nocomplain x
set info {}
proc p {} {
trace add variable x write traceArray
@@ -267,7 +265,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body {
# trace: after appending all arguments to the list.
test trace-3.1 {trace variable read-modify-writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalarAppend
append x 123
@@ -276,7 +274,7 @@ test trace-3.1 {trace variable read-modify-writes} {
set info
} {x {} read 0 123456}
test trace-3.2 {trace variable read-modify-writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write} traceScalarAppend
append x 123
@@ -287,14 +285,14 @@ test trace-3.2 {trace variable read-modify-writes} {
# Basic unset-tracing on variables
test trace-4.1 {trace variable unsets} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset traceScalar
- catch {unset x}
+ unset -nocomplain x
set info
} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.2 {variable mustn't exist during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x unset traceScalar
@@ -302,7 +300,7 @@ test trace-4.2 {variable mustn't exist during unset trace} {
set info
} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.3 {unset traces mustn't be called during reads and writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset traceScalar
set x 44
@@ -310,15 +308,15 @@ test trace-4.3 {unset traces mustn't be called during reads and writes} {
set info
} {}
test trace-4.4 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 18
set info {}
trace add variable x(1) unset traceArray
- catch {unset x(1)}
+ unset -nocomplain x(1)
set info
} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.5 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x(1) unset traceArray
@@ -326,7 +324,7 @@ test trace-4.5 {trace unsets on array elements} {
set info
} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.6 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x(1) unset traceArray
@@ -334,15 +332,15 @@ test trace-4.6 {trace unsets on array elements} {
set info
} {x 1 unset 1 {can't read "x(1)": no such variable}}
test trace-4.7 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x unset traceProc
- catch {unset x(0)}
+ unset -nocomplain x(0)
set info
} {}
test trace-4.8 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set x(2) 144
set x(3) 14
@@ -352,7 +350,7 @@ test trace-4.8 {trace unsets on whole arrays} {
set info
} {x 1 unset}
test trace-4.9 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set x(2) 144
set x(3) 14
@@ -364,7 +362,7 @@ test trace-4.9 {trace unsets on whole arrays} {
# Array tracing on variables
test trace-5.1 {array traces fire on accesses via [array]} {
- catch {unset x}
+ unset -nocomplain x
set x(b) 2
trace add variable x array traceArray2
set ::info {}
@@ -372,7 +370,7 @@ test trace-5.1 {array traces fire on accesses via [array]} {
set ::info
} {x {} array}
test trace-5.2 {array traces do not fire on normal accesses} {
- catch {unset x}
+ unset -nocomplain x
set x(b) 2
trace add variable x array traceArray2
set ::info {}
@@ -381,7 +379,7 @@ test trace-5.2 {array traces do not fire on normal accesses} {
set ::info
} {}
test trace-5.3 {array traces do not outlive variable} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set ::info {}
set x(a) 1
@@ -390,19 +388,19 @@ test trace-5.3 {array traces do not outlive variable} {
set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set result [trace info variable x]
set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
- catch {unset x}
+ unset -nocomplain x
trace variable x a traceArray2
set result [trace vinfo x]
set result
} [list [list a traceArray2]]
test trace-5.6 {array traces don't fire on scalar variables} {
- catch {unset x}
+ unset -nocomplain x
set x foo
trace add variable x array traceArray2
set ::info {}
@@ -410,14 +408,14 @@ test trace-5.6 {array traces don't fire on scalar variables} {
set ::info
} {}
test trace-5.7 {array traces fire for undefined variables} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set ::info {}
array set x {a 1}
set ::info
} {x {} array}
test trace-5.8 {array traces fire for undefined variables} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array {set x(foo) 1 ;#}
set res "names: [array names x]"
} {names: foo}
@@ -425,7 +423,7 @@ test trace-5.8 {array traces fire for undefined variables} {
# Trace multiple trace types at once.
test trace-6.1 {multiple ops traced at once} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write unset} traceProc
catch {set x}
@@ -436,7 +434,7 @@ test trace-6.1 {multiple ops traced at once} {
set info
} {x {} read x {} write x {} read x {} write x {} unset}
test trace-6.2 {multiple ops traced on array element} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) {read write unset} traceProc
catch {set x(0)}
@@ -448,7 +446,7 @@ test trace-6.2 {multiple ops traced on array element} {
set info
} {x 0 read x 0 write x 0 read x 0 write x 0 unset}
test trace-6.3 {multiple ops traced on whole array} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write unset} traceProc
catch {set x(0)}
@@ -463,7 +461,7 @@ test trace-6.3 {multiple ops traced on whole array} {
# Check order of invocation of traces
test trace-7.1 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read "traceTag 1"
trace add variable x read "traceTag 2"
@@ -474,7 +472,7 @@ test trace-7.1 {order of invocation of traces} {
set info
} {3 2 1 3 2 1}
test trace-7.2 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 44
set info {}
trace add variable x(0) read "traceTag 1"
@@ -484,7 +482,7 @@ test trace-7.2 {order of invocation of traces} {
set info
} {3 2 1}
test trace-7.3 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 44
set info {}
trace add variable x(0) read "traceTag 1"
@@ -500,7 +498,7 @@ test trace-7.3 {order of invocation of traces} {
# Check effects of errors in trace procedures
test trace-8.1 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x read "traceTag 1"
@@ -508,7 +506,7 @@ test trace-8.1 {error returns from traces} {
list [catch {set x} msg] $msg $info
} {1 {can't read "x": trace returned error} {}}
test trace-8.2 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x write "traceTag 1"
@@ -516,14 +514,14 @@ test trace-8.2 {error returns from traces} {
list [catch {set x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-8.3 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x write traceError
list [catch {append x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-8.4 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x unset "traceTag 1"
@@ -531,7 +529,7 @@ test trace-8.4 {error returns from traces} {
list [catch {unset x} msg] $msg $info
} {0 {} 1}
test trace-8.5 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 123
set info {}
trace add variable x(0) read "traceTag 1"
@@ -541,7 +539,7 @@ test trace-8.5 {error returns from traces} {
list [catch {set x(0)} msg] $msg $info
} {1 {can't read "x(0)": trace returned error} 3}
test trace-8.6 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
trace add variable x unset traceError
list [catch {unset x} msg] $msg
@@ -550,7 +548,7 @@ test trace-8.7 {error returns from traces} {
# This test just makes sure that the memory for the error message
# gets deallocated correctly when the trace is invoked again or
# when the trace is deleted.
- catch {unset x}
+ unset -nocomplain x
set x 123
trace add variable x read traceError
catch {set x}
@@ -571,7 +569,7 @@ test trace-8.8 {error returns from traces} {
trace add variable ::x write [list foo $::x]
error "foo"
}
- catch {unset ::x ::y}
+ unset -nocomplain ::x ::y
set x junk
trace add variable ::x write [list foo $x]
for {set y 0} {$y<100} {incr y} {
@@ -585,31 +583,31 @@ test trace-8.8 {error returns from traces} {
# a new copy of the variables.
test trace-9.1 {be sure variable is unset before trace is called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x}}
+ trace add variable x unset {traceCheck {uplevel 1 set x}}
unset x
set info
} {1 {can't read "x": no such variable}}
test trace-9.2 {be sure variable is unset before trace is called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x 22}}
+ trace add variable x unset {traceCheck {uplevel 1 set x 22}}
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel trace info variable x}}
+ trace add variable x unset {traceCheck {uplevel 1 trace info variable x}}
unset x
set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
@@ -618,23 +616,23 @@ test trace-9.4 {set new trace during unset trace} {
} {0 {} {unset traceProc}}
test trace-10.1 {make sure array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
+ trace add variable x(0) unset {traceCheck {uplevel 1 set x(0)}}
unset x(0)
set info
} {1 {can't read "x(0)": no such element in array}}
test trace-10.2 {make sure array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}}
+ trace add variable x(0) unset {traceCheck {uplevel 1 set x(0) zzz}}
unset x(0)
concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
@@ -642,49 +640,49 @@ test trace-10.3 {array elements are unset before traces are called} {
set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
- catch {unset x(0)}
+ trace add variable x(0) unset {traceCheck {uplevel 1 {trace add variable x(0) read {}}}}
+ unset -nocomplain x(0)
concat $info [trace info variable x(0)]
} {0 {} {read {}}}
test trace-11.1 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x(0)}}
+ trace add variable x unset {traceCheck {uplevel 1 set x(0)}}
unset x
set info
} {1 {can't read "x(0)": no such variable}}
test trace-11.2 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x(y) 22}}
+ trace add variable x unset {traceCheck {uplevel 1 set x(y) 22}}
unset x
concat $info [list [catch {set x(y)} msg] $msg]
} {0 22 0 22}
test trace-11.3 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- trace add variable x unset {traceCheck {uplevel array exists x}}
+ trace add variable x unset {traceCheck {uplevel 1 array exists x}}
unset x
set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- set cmd {traceCheck {uplevel {trace info variable x}}}
+ set cmd {traceCheck {uplevel 1 {trace info variable x}}}
trace add variable x unset $cmd
unset x
set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
@@ -692,7 +690,7 @@ test trace-11.5 {set new array trace during unset trace} {
concat $info [trace info variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; set x 44}}
@@ -703,52 +701,52 @@ test trace-11.6 {create scalar during array unset trace} {
# Check special conditions (e.g. errors) in Tcl_TraceVar2.
test trace-12.1 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
list [catch {set x 22} msg] $msg
} {1 {can't set "x": variable is array}}
test trace-12.2 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
list [catch {set x(0)} msg] $msg
} {1 {can't read "x(0)": no such element in array}}
test trace-12.3 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
set x(0) 22
set info
} {x 0 write}
test trace-12.4 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
list [catch {set x} msg] $msg
} {1 {can't read "x": no such variable}}
test trace-12.5 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
set x 22
set info
} {x {} write}
test trace-12.6 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
set x(0) 22
set info
} {x 0 write}
test trace-12.7 {create array element during read trace} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
trace add variable x read {traceCrtElement xyzzy}
list [catch {set x(3)} msg] $msg
} {0 xyzzy}
test trace-12.8 {errors when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set x 44
list [catch {trace add variable x(0) write traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}
@@ -762,7 +760,7 @@ test trace-13.1 {delete one trace from another} {
trace remove variable x read {traceTag 3}
trace remove variable x read {traceTag 4}
}
- catch {unset x}
+ unset -nocomplain x
set x 44
set info {}
trace add variable x read {traceTag 1}
@@ -916,13 +914,13 @@ test trace-14.11 {trace command, "trace variable" errors} {
test trace-14.12 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
} {}
test trace-14.13 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
@@ -930,7 +928,7 @@ test trace-14.13 {trace command ("remove variable" option)} {
set info
} {}
test trace-14.14 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag 1}
trace add variable x write traceProc
@@ -945,7 +943,7 @@ test trace-14.14 {trace command ("remove variable" option)} {
set info
} {2 x {} write 1 2 1 2}
test trace-14.15 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag 1}
trace remove variable x write non_existent
@@ -953,27 +951,27 @@ test trace-14.15 {trace command ("remove variable" option)} {
set info
} {1}
test trace-14.16 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x write {traceTag 1}
trace add variable x write traceProc
trace add variable x write {traceTag 2}
trace info variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.17 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace info variable x
} {}
test trace-14.18 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace info variable x(0)
} {}
test trace-14.19 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set x 44
trace info variable x(0)
} {}
test trace-14.20 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set x 44
trace add variable x write {traceTag 1}
proc check {} {global x; trace info variable x}
@@ -983,7 +981,7 @@ test trace-14.20 {trace command ("info variable" option)} {
# Check fancy trace commands (long ones, weird arguments, etc.)
test trace-15.1 {long trace command} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag {This is a very very long argument. It's \
designed to test out the facilities of TraceVarProc for dealing \
@@ -1001,14 +999,14 @@ test trace-15.2 {long trace command result to ignore} {
proc longResult {args} {return "quite a bit of text, designed to
generate a core leak if this command file is invoked over and over again
and memory isn't being recycled correctly"}
- catch {unset x}
+ unset -nocomplain x
trace add variable x write longResult
set x 44
set x 5
set x abcde
} abcde
test trace-15.3 {special list-handling in trace commands} {
- catch {unset "x y z"}
+ unset -nocomplain "x y z"
set "x y z(a\n\{)" 44
set info {}
trace add variable "x y z(a\n\{)" write traceProc
@@ -1020,18 +1018,18 @@ test trace-15.3 {special list-handling in trace commands} {
proc traceUnset {unsetName args} {
global info
- upvar $unsetName x
+ upvar 1 $unsetName x
lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg
}
proc traceReset {unsetName resetName args} {
global info
- upvar $unsetName x $resetName y
+ upvar 1 $unsetName x $resetName y
lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg
}
proc traceReset2 {unsetName resetName args} {
global info
- lappend info [catch {uplevel unset $unsetName} msg] $msg \
- [catch {uplevel set $resetName xyzzy} msg] $msg
+ lappend info [catch {uplevel 1 unset $unsetName} msg] $msg \
+ [catch {uplevel 1 set $resetName xyzzy} msg] $msg
}
proc traceAppend {string name1 name2 op} {
global info
@@ -1039,7 +1037,7 @@ proc traceAppend {string name1 name2 op} {
}
test trace-16.1 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceUnset y}
@@ -1047,49 +1045,49 @@ test trace-16.1 {unsets during read traces} {
lappend info [catch {set y} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-16.2 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceUnset y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}
test trace-16.3 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceUnset y}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-16.4 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceReset y y}
lappend info [catch {set y} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.5 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset y(0) y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.6 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-16.7 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset2 y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}
test trace-16.8 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y write {traceUnset y}
@@ -1097,91 +1095,91 @@ test trace-16.8 {unsets during write traces} {
lappend info [catch {set y xxx} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.9 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceUnset y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.10 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceUnset y}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.11 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y write {traceReset y y}
lappend info [catch {set y xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.12 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset y(0) y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.13 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-16.14 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset2 y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.15 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y unset {traceUnset y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}}
test trace-16.16 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceUnset y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}}
test trace-16.17 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceUnset y}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-16.18 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y unset {traceReset2 y y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.19 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceReset2 y(0) y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.20 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceReset2 y y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.21 {unsets cancelling traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceAppend first}
@@ -1191,7 +1189,7 @@ test trace-16.21 {unsets cancelling traces} {
lappend info [catch {set y} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-16.22 {unsets cancelling traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceAppend first}
@@ -1204,19 +1202,19 @@ test trace-16.22 {unsets cancelling traces} {
# Check various non-interference between traces and other things.
test trace-17.1 {trace doesn't prevent unset errors} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset {traceProc}
list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
- catch {unset x}
+ unset -nocomplain x
proc p1 {} {global x; trace add variable x write traceProc}
p1
trace info variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
- catch {unset x}
+ unset -nocomplain x
set info {}
proc p1 {} {global x; trace add variable x write traceProc}
p1
@@ -1229,7 +1227,7 @@ test trace-17.3 {traced variables must survive procedure exits} {
test trace-18.1 {unset traces on procedure returns} {
proc p1 {x y} {set a 44; p2 14}
- proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}}
+ proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}}
set info {}
p1 foo bar
set info
@@ -1269,8 +1267,7 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} {
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
-catch {unset x}
-catch {unset y}
+unset -nocomplain x y
test trace-19.0.1 {trace add command (command existence)} {
# Just in case!
@@ -1312,6 +1309,7 @@ test trace-19.3 {command rename traces don't fire on command deletion} {
test trace-19.4 {trace add command rename doesn't trace recreated commands} {
proc foo {} {}
catch {rename bar {}}
+ set info {}
trace add command foo rename traceCommand
proc foo {} {}
rename foo bar
@@ -1324,25 +1322,49 @@ test trace-19.5 {trace add command deleted removes traces} {
trace info command foo
} {}
-namespace eval tc {}
-proc tc::tcfoo {} {}
-test trace-19.6 {trace add command rename in namespace} {
+test trace-19.6 {trace add command rename in namespace} -setup {
+ namespace eval tc {}
+ proc tc::tcfoo {} {}
+} -body {
trace add command tc::tcfoo rename traceCommand
rename tc::tcfoo tc::tcbar
set info
-} {::tc::tcfoo ::tc::tcbar rename}
-test trace-19.7 {trace add command rename in namespace back again} {
+} -cleanup {
+ namespace delete tc
+} -result {::tc::tcfoo ::tc::tcbar rename}
+test trace-19.7 {trace add command rename in namespace back again} -setup {
+ namespace eval tc {}
+ proc tc::tcfoo {} {}
+} -body {
+ trace add command tc::tcfoo rename traceCommand
+ rename tc::tcfoo tc::tcbar
rename tc::tcbar tc::tcfoo
set info
-} {::tc::tcbar ::tc::tcfoo rename}
-test trace-19.8 {trace add command rename in namespace to out of namespace} {
+} -cleanup {
+ namespace delete tc
+} -result {::tc::tcbar ::tc::tcfoo rename}
+test trace-19.8 {trace add command rename in namespace to out of namespace} -setup {
+ namespace eval tc {}
+ proc tc::tcfoo {} {}
+} -body {
+ trace add command tc::tcfoo rename traceCommand
rename tc::tcfoo tcbar
set info
-} {::tc::tcfoo ::tcbar rename}
-test trace-19.9 {trace add command rename back into namespace} {
+} -cleanup {
+ catch {rename tcbar {}}
+ namespace delete tc
+} -result {::tc::tcfoo ::tcbar rename}
+test trace-19.9 {trace add command rename back into namespace} -setup {
+ namespace eval tc {}
+ proc tc::tcfoo {} {}
+} -body {
+ trace add command tc::tcfoo rename traceCommand
+ rename tc::tcfoo tcbar
rename tcbar tc::tcfoo
set info
-} {::tcbar ::tc::tcfoo rename}
+} -cleanup {
+ namespace delete tc
+} -result {::tcbar ::tc::tcfoo rename}
test trace-19.10 {trace add command failed rename doesn't trigger trace} {
set info {}
proc foo {} {}
@@ -1353,11 +1375,18 @@ test trace-19.10 {trace add command failed rename doesn't trigger trace} {
} {}
catch {rename foo {}}
catch {rename bar {}}
-test trace-19.11 {trace add command qualifies when renamed in namespace} {
+
+test trace-19.11 {trace add command qualifies when renamed in namespace} -setup {
+ namespace eval tc {}
+ proc tc::tcfoo {} {}
+} -body {
set info {}
+ trace add command tc::tcfoo {rename delete} traceCommand
namespace eval tc {rename tcfoo tcbar}
set info
-} {::tc::tcfoo ::tc::tcbar rename}
+} -cleanup {
+ namespace delete tc
+} -result {::tc::tcfoo ::tc::tcbar rename}
# Make sure it exists again
proc foo {} {}
@@ -1542,8 +1571,7 @@ proc foo {b} { set a $b }
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
-catch {unset x}
-catch {unset y}
+unset -nocomplain x y
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
@@ -1674,6 +1702,16 @@ test trace-21.11 {trace execution and alias} -setup {
rename ::x {}
} -result {:: ::}
+proc set2 args {
+ set {*}$args
+}
+
+test trace-21.12 {bug 2438181} -setup {
+ trace add execution set2 leave {puts one two three #;}
+} -body {
+ set2 a hello
+} -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channelId? string"}
+
proc factorial {n} {
if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
return 1
@@ -2050,7 +2088,7 @@ test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)}
trace remove execution foo {enter enterstep leavestep leave} \
[list traceExecute foo]
rename foo {}
- catch {unset a}
+ unset -nocomplain a
join $info "\n"
} {foo foo enter
foo {set a 1} enterstep
@@ -2623,6 +2661,13 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup {
rename dotrace {}
rename foo {}
} -result {3 | 0 1 1}
+
+test trace-40.1 {execution trace errors become command errors} {
+ proc foo args {}
+ trace add execution foo enter {rename foo {}; error bar;#}
+ catch foo m
+ return -level 0 $m[unset m]
+} bar
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
@@ -2634,9 +2679,8 @@ catch {rename traceproc {}}
catch {rename runbase {}}
# Unset the variable when done
-catch {unset info}
-catch {unset base}
+unset -nocomplain info base
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index 2453e01..e4613ed 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -365,20 +365,21 @@ test unixFCmd-17.4 {SetPermissionsAttribute} -setup {
close [open foo.test w]
set ::i 4
-proc permcheck {testnum permstr expected} {
+proc permcheck {testnum permList expected} {
test $testnum {SetPermissionsAttribute} {unix notRoot} {
+ set result {}
+ foreach permstr $permList {
file attributes foo.test -permissions $permstr
- file attributes foo.test -permissions
+ lappend result [file attributes foo.test -permissions]
+ }
+ set result
} $expected
}
permcheck unixFCmd-17.5 rwxrwxrwx 00777
permcheck unixFCmd-17.6 r--r---w- 00442
-permcheck unixFCmd-17.7 0 00000
-permcheck unixFCmd-17.8 u+rwx,g+r 00740
-permcheck unixFCmd-17.9 u-w 00540
-permcheck unixFCmd-17.10 o+rwx 00547
+permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 00740 00540 00547}
permcheck unixFCmd-17.11 --x--x--x 00111
-permcheck unixFCmd-17.12 a+rwx 00777
+permcheck unixFCmd-17.12 {0 a+rwx} {00000 00777}
file delete -force -- foo.test
test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup {
diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test
new file mode 100644
index 0000000..120f362
--- /dev/null
+++ b/tests/unixForkEvent.test
@@ -0,0 +1,45 @@
+# This file contains a collection of tests for the procedures in the file
+# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1995-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.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+testConstraint testfork [llength [info commands testfork]]
+
+# Test if the notifier thread is well initialized in a forked interpreter
+# by Tcl_InitNotifier
+test unixforkevent-1.1 {fork and test writeable event} \
+ -constraints {testfork nonPortable} \
+ -body {
+ set myFolder [makeDirectory unixtestfork]
+ set pid [testfork]
+ if {$pid == 0} {
+ # we are the forked process
+ set result initialized
+ set h [open [file join $myFolder test.txt] w]
+ fileevent $h writable\
+ "set result writable;\
+ after cancel [after 1000 {set result timeout}]"
+ vwait result
+ close $h
+ makeFile $result result.txt $myFolder
+ exit
+ }
+ # we are the original process
+ while {![file readable [file join $myFolder result.txt]]} {}
+ viewFile result.txt $myFolder
+ } \
+ -result {writable} \
+ -cleanup {
+ catch { removeFolder $myFolder }
+ }
+
+::tcltest::cleanupTests
+return
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 9ba9c11..05338ed 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -11,7 +11,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.2
-namespace import -force ::tcltest::*
+namespace import ::tcltest::*
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C
@@ -44,11 +44,11 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
set pipe1 [open "|[list [interpreter]]" r+]
puts $pipe1 {
proc accept {channel host port} {
- puts $channel {puts [fconfigure stdin -peername]; exit}
+ puts $channel {puts [chan configure stdin -peername]; exit}
close $channel
exit
}
- puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
+ puts [chan configure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
vwait forever \
}
# Note the backslash above; this is important to make sure that the whole
@@ -64,8 +64,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
set pipe2 [open "|[list [interpreter] <@$sock]" r]
set result [gets $pipe2]
# Clear any pending data; stops certain kinds of (non-important) errors
- fconfigure $pipe1 -blocking 0; gets $pipe1
- fconfigure $pipe2 -blocking 0; gets $pipe2
+ chan configure $pipe1 -blocking 0; gets $pipe1
+ chan configure $pipe2 -blocking 0; gets $pipe2
# Close the pipes and the socket.
close $pipe2
close $pipe1
@@ -329,7 +329,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
- fconfigure $f -buffering none
+ chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
@@ -344,7 +344,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup {
set env(LANG) japanese
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
- fconfigure $f -buffering none
+ chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
@@ -390,7 +390,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
} -returnCodes 0
# cleanup
-catch {unset env(LANG)}
+unset -nocomplain env(LANG)
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
diff --git a/tests/unknown.test b/tests/unknown.test
index 40be6602..e80d3a6 100644
--- a/tests/unknown.test
+++ b/tests/unknown.test
@@ -11,12 +11,10 @@
# 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
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
-catch {unset x}
+unset -nocomplain x
catch {rename unknown unknown.old}
test unknown-1.1 {non-existent "unknown" command} {
@@ -59,7 +57,7 @@ test unknown-4.1 {errors in "unknown" procedure} {
# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
-::tcltest::cleanupTests
+cleanupTests
return
# Local Variables:
diff --git a/tests/utf.test b/tests/utf.test
index c41cfe3..ebab967 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -337,8 +337,8 @@ test utf-21.11 {TclUniCharIsControl} {
string is control \u00ad
} {1}
test utf-21.12 {unicode control char in regc_locale.c} {
- # [Bug 3464428]
- regexp {^[[:cntrl:]]$} \u00ad
+ # [Bug 3464428], [Bug a876646efe]
+ regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad
} {1}
test utf-22.1 {TclUniCharIsWordChar} {
diff --git a/tests/var.test b/tests/var.test
index ed7e930..5939100 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -793,6 +793,75 @@ test var-19.1 {crash when freeing locals hashtable: Bug 3037525} {
foo ; # This crashes without the fix for the bug
rename foo {}
} {}
+
+test var-20.1 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ array set x {a 1}
+ }}
+ array size x
+} -result 1
+test var-20.2 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ array set x {}
+ }}
+ array size x
+} -result 0
+test var-20.3 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ array set ::x {a 1}
+ }}
+ array size x
+} -result 1
+test var-20.4 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ array set ::x {}
+ }}
+ array size x
+} -result 0
+test var-20.5 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ eval {array set x {a 1}}
+ }}
+ array size x
+} -result 1
+test var-20.6 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ eval {array set x {}}
+ }}
+ array size x
+} -result 0
+test var-20.7 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ eval {array set ::x {a 1}}
+ }}
+ array size x
+} -result 1
+test var-20.8 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ eval {array set ::x {}}
+ }}
+ array size x
+} -result 0
catch {namespace delete ns}
catch {unset arr}
diff --git a/tests/zlib.test b/tests/zlib.test
index 891dba0..c469eea 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -366,6 +366,25 @@ test zlib-8.15 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358}
+test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup {
+ # Actual data isn't very important; needs to be substantially larger than
+ # the internal buffer (32kB) and incompressible.
+ set largeData {}
+ for {set i 0;expr srand(1)} {$i < 100000} {incr i} {
+ append largeData [lindex "a b c d e f g h i j k l m n o p" \
+ [expr {int(16*rand())}]]
+ }
+ set file [makeFile {} test.gz]
+} -constraints zlib -body {
+ set f [open $file wb]
+ fconfigure $f -buffering none
+ zlib push gzip $f
+ puts -nonewline $f $largeData
+ close $f
+ file size $file
+} -cleanup {
+ removeFile $file
+} -result 57647
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]