summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/chanio.test23
-rw-r--r--tests/cmdAH.test15
-rw-r--r--tests/env.test12
-rw-r--r--tests/exec.test3
-rw-r--r--tests/fileName.test4
-rw-r--r--tests/history.test5
-rw-r--r--tests/interp.test58
-rw-r--r--tests/io.test35
-rw-r--r--tests/load.test54
-rw-r--r--tests/msgcat.test9
-rw-r--r--tests/namespace.test20
-rw-r--r--tests/obj.test1
-rw-r--r--tests/parseOld.test13
-rw-r--r--tests/resolver.test117
-rw-r--r--tests/safe.test20
-rw-r--r--tests/set-old.test4
-rw-r--r--tests/set.test113
-rw-r--r--tests/socket.test1
-rw-r--r--tests/tcltest.test7
-rw-r--r--tests/unload.test170
-rw-r--r--tests/var.test98
-rw-r--r--tests/zlib.test35
22 files changed, 616 insertions, 201 deletions
diff --git a/tests/chanio.test b/tests/chanio.test
index 3017e81..075b64e 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -4160,12 +4160,20 @@ test chan-io-33.4 {Tcl_Gets with long line} -setup {
} -cleanup {
chan close $f
} -result {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
-test chan-io-33.5 {Tcl_Gets with long line} {
+test chan-io-33.5 {Tcl_Gets with long line} -setup {
+ set f [open $path(test3) w]
+ puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ close $f
+} -body {
set f [open $path(test3)]
set x [chan gets $f y]
chan close $f
list $x $y
-} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
+} -result {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test chan-io-33.6 {Tcl_Gets and end of file} -setup {
file delete $path(test3)
set x {}
@@ -6765,7 +6773,12 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} {
chan close $out
file size $path(utf8-fcopy.txt)
} 5
-test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} {
+test chan-io-52.11 {TclCopyChannel & encodings} -setup {
+ set f [open $path(utf8-fcopy.txt) w]
+ fconfigure $f -encoding utf-8
+ puts $f "\u0410\u0410"
+ close $f
+} -constraints {fcopy} -body {
# binary to encoding => the input has to be in utf-8 to make sense to the
# encoder
set in [open $path(utf8-fcopy.txt) r]
@@ -6777,7 +6790,9 @@ test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} {
chan close $in
chan close $out
file size $path(kyrillic.txt)
-} 3
+} -cleanup {
+ file delete $path(utf8-fcopy.txt)
+} -result 3
test chan-io-53.1 {CopyData} -setup {
file delete $path(test1)
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index ef933cb..b4ef605 100644
--- a/tests/cmdAH.test
+++ b/tests/cmdAH.test
@@ -141,9 +141,13 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup {
} -cleanup {
cd $dir
} -result {/}
-test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -returnCodes error -body {
+test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -setup {
+ set dir [pwd]
+} -returnCodes error -body {
cd .\0
-} -result "couldn't change working directory to \".\0\": no such file or directory"
+} -cleanup {
+ cd $dir
+} -match glob -result "couldn't change working directory to \".\0\": *"
test cmdAH-2.7 {Tcl_ConcatObjCmd} {
concat
} {}
@@ -878,9 +882,10 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
# On pc, must be a .exe, .com, etc.
- set x [file exe $gorpfile]
+ set x {}
set gorpexes {}
- foreach ext {exe com cmd bat ps1} {
+ foreach ext {exe com cmd bat} {
+ lappend x [file exe nosuchfile.$ext]
set gorpexe [makeFile foo gorp.$ext]
lappend gorpexes $gorpexe
lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]]
@@ -890,7 +895,7 @@ test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
foreach gorpexe $gorpexes {
removeFile $gorpexe
}
-} -result {0 1 1 1 1 1 1 1 1 1 1}
+} -result {0 1 1 0 1 1 0 1 1 0 1 1}
test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} {
# Directories are always executable.
file exe $dirfile
diff --git a/tests/env.test b/tests/env.test
index 9f59fbc..0dd4f98 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
# Some tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
-
+
#
# These tests will run on any platform (and indeed crashed on the Mac). So put
# them before you test for the existance of exec.
@@ -147,6 +147,7 @@ test env-2.2 {adding environment variables} -setup {
} -result {NAME1=test string}
test env-2.3 {adding environment variables} -setup {
encoding system iso8859-1
+ set env(NAME1) "test string"
} -constraints {exec} -body {
set env(NAME2) "more"
getenv
@@ -156,6 +157,8 @@ test env-2.3 {adding environment variables} -setup {
NAME2=more}
test env-2.4 {adding environment variables} -setup {
encoding system iso8859-1
+ set env(NAME1) "test string"
+ set env(NAME2) "more"
} -constraints {exec} -body {
set env(XYZZY) "garbage"
getenv
@@ -165,7 +168,9 @@ test env-2.4 {adding environment variables} -setup {
NAME2=more
XYZZY=garbage}
+set env(NAME1) "test string"
set env(NAME2) "new value"
+set env(XYZZY) "garbage"
test env-3.1 {changing environment variables} -setup {
encoding system iso8859-1
} -constraints {exec} -body {
@@ -177,6 +182,7 @@ test env-3.1 {changing environment variables} -setup {
} -result {NAME1=test string
NAME2=new value
XYZZY=garbage}
+unset -nocomplain env(NAME2)
test env-4.1 {unsetting environment variables: default} -setup {
encoding system iso8859-1
@@ -195,6 +201,7 @@ test env-4.2 {unsetting environment variables} -setup {
unset env(XYZZY)
encoding system $sysenc
} -result {XYZZY=garbage}
+unset -nocomplain env(NAME1) env(XYZZY)
test env-4.3 {setting international environment variables} -setup {
encoding system iso8859-1
} -constraints {exec} -body {
@@ -213,6 +220,7 @@ test env-4.4 {changing international environment variables} -setup {
} -result {\u00a7=\u00a7}
test env-4.5 {unsetting international environment variables} -setup {
encoding system iso8859-1
+ set env(\ua7) \ua7
} -body {
set env(\ub6) \ua7
unset env(\ua7)
@@ -323,7 +331,7 @@ test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy
return [info exists ::env(test7_3)]
}}
} -result 1
-
+
# Restore the environment variables at the end of the test.
foreach name [array names env] {
diff --git a/tests/exec.test b/tests/exec.test
index 38927d3..2a4b31e 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -695,9 +695,6 @@ test exec-20.1 {exec .CMD file} -constraints {win} -body {
exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1"
viewFile $log
} -result "\"Testing exec-20.1\""
-
-
-
# ----------------------------------------------------------------------
# cleanup
diff --git a/tests/fileName.test b/tests/fileName.test
index a19bd1e..387d844 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -1468,7 +1468,7 @@ if {[testConstraint testsetplatform]} {
}
test filename-17.2 {windows specific glob with executable} -body {
makeDirectory execglob
- foreach ext {exe com cmd bat ps1 notexecutable} {
+ foreach ext {exe com cmd bat notexecutable} {
makeFile contents execglob/abc.$ext
}
lsort [glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x *]
@@ -1477,7 +1477,7 @@ test filename-17.2 {windows specific glob with executable} -body {
removeFile execglob/abc.$ext
}
removeDirectory execglob
-} -result {abc.bat abc.cmd abc.com abc.exe abc.ps1}
+} -result {abc.bat abc.cmd abc.com abc.exe}
test filename-17.3 {Bug 2571597} win {
set p /a
file pathtype $p
diff --git a/tests/history.test b/tests/history.test
index 1a255a4..c2d2124 100644
--- a/tests/history.test
+++ b/tests/history.test
@@ -233,6 +233,7 @@ if {[testConstraint history]} {
test history-8.1 {clear option} history {catch {history clear junk}} 1
test history-8.2 {clear option} history {history clear} {}
if {[testConstraint history]} {
+ history clear
history add "Testing"
}
test history-8.3 {clear option} history {history} { 1 Testing}
@@ -248,3 +249,7 @@ test history-9.2 {miscellaneous} history {
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/interp.test b/tests/interp.test
index 6c9fb56..ed76f1a 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -71,9 +71,11 @@ test interp-2.2 {basic interpreter creation} {
test interp-2.3 {basic interpreter creation} {
catch {interp create -safe}
} 0
-test interp-2.4 {basic interpreter creation} {
- list [catch {interp create a} msg] $msg
-} {1 {interpreter named "a" already exists, cannot create}}
+test interp-2.4 {basic interpreter creation} -setup {
+ catch {interp create a}
+} -returnCodes error -body {
+ interp create a
+} -result {interpreter named "a" already exists, cannot create}
test interp-2.5 {basic interpreter creation} {
interp create b -safe
} b
@@ -89,11 +91,13 @@ test interp-2.8 {basic interpreter creation} {
test interp-2.9 {basic interpreter creation} {
interp create -safe -- -froboz1
} -froboz1
-test interp-2.10 {basic interpreter creation} {
+test interp-2.10 {basic interpreter creation} -setup {
+ catch {interp create a}
+} -body {
interp create {a x1}
interp create {a x2}
interp create {a x3} -safe
-} {a x3}
+} -result {a x3}
test interp-2.11 {anonymous interps vs existing procs} {
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy thenum
@@ -140,19 +144,26 @@ test interp-3.5 {testing interp exists and interp slaves} -body {
test interp-3.6 {testing interp exists and interp slaves} {
interp exists
} 1
-test interp-3.7 {testing interp exists and interp slaves} {
+test interp-3.7 {testing interp exists and interp slaves} -setup {
+ catch {interp create a}
+} -body {
interp slaves
-} a
+} -result a
test interp-3.8 {testing interp exists and interp slaves} -body {
interp slaves a b c
} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"}
-test interp-3.9 {testing interp exists and interp slaves} {
+test interp-3.9 {testing interp exists and interp slaves} -setup {
+ catch {interp create a}
+} -body {
interp create {a a2} -safe
expr {"a2" in [interp slaves a]}
-} 1
-test interp-3.10 {testing interp exists and interp slaves} {
+} -result 1
+test interp-3.10 {testing interp exists and interp slaves} -setup {
+ catch {interp create a}
+ catch {interp create {a a2}}
+} -body {
interp exists {a a2}
-} 1
+} -result 1
# Part 3: Testing "interp delete"
test interp-3.11 {testing interp delete} {
@@ -222,6 +233,7 @@ test interp-6.3 {testing eval} {
a eval {proc foo {} {expr 3 + 5}}
a eval foo
} 8
+catch {a eval {proc foo {} {expr 3 + 5}}}
test interp-6.4 {testing eval} {
interp eval a foo
} 8
@@ -230,6 +242,7 @@ test interp-6.5 {testing eval} {
interp eval {a x2} {proc frob {} {expr 4 * 9}}
interp eval {a x2} frob
} 36
+catch {interp create {a x2}}
test interp-6.6 {testing eval} -returnCodes error -body {
interp eval {a x2} foo
} -result {invalid command name "foo"}
@@ -243,9 +256,11 @@ proc in_master {args} {
test interp-7.1 {testing basic alias creation} {
a alias foo in_master
} foo
+catch {a alias foo in_master}
test interp-7.2 {testing basic alias creation} {
a alias bar in_master a1 a2 a3
} bar
+catch {a alias bar in_master a1 a2 a3}
# Test 6.3 has been deleted.
test interp-7.3 {testing basic alias creation} {
a alias foo
@@ -476,9 +491,13 @@ test interp-13.4 {testing issafe arg checking} {
} {1 {wrong # args: should be "a issafe"}}
# part 14: testing interp aliases
-test interp-14.1 {testing interp aliases} {
- interp aliases
-} ""
+test interp-14.1 {testing interp aliases} -setup {
+ interp create abc
+} -body {
+ interp eval abc {interp aliases}
+} -cleanup {
+ interp delete abc
+} -result ""
test interp-14.2 {testing interp aliases} {
catch {interp delete a}
interp create a
@@ -587,6 +606,17 @@ test interp-14.10 {testing interp-alias: error messages} -setup {
invoked from within
"a 1"}
+test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185}} -setup {
+ set interp [interp create [info cmdcount]]
+ interp eval $interp {
+ proc {} args {return $args}
+ }
+
+} -body {
+ interp alias {} p1 $interp {}
+ p1 one two three
+} -result {one two three}
+
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
catch {interp delete z}
diff --git a/tests/io.test b/tests/io.test
index 46856b6..6e7420d 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -44,6 +44,7 @@ testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
+testConstraint testobj [llength [info commands testobj]]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
@@ -4285,6 +4286,13 @@ test io-33.4 {Tcl_Gets with long line} {
close $f
set x
} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
+set f [open $path(test3) w]
+puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
+close $f
test io-33.5 {Tcl_Gets with long line} {
set f [open $path(test3)]
set x [gets $f y]
@@ -7141,7 +7149,12 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} {
file size $path(utf8-fcopy.txt)
} 5
-test io-52.11 {TclCopyChannel & encodings} {fcopy} {
+test io-52.11 {TclCopyChannel & encodings} -setup {
+ set out [open $path(utf8-fcopy.txt) w]
+ fconfigure $out -encoding utf-8 -translation lf
+ puts $out "\u0410\u0410"
+ close $out
+} -constraints {fcopy} -body {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
@@ -7157,7 +7170,7 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} {
close $out
file size $path(kyrillic.txt)
-} 3
+} -result 3
test io-52.12 {coverage of -translation auto} {
file delete $path(test1) $path(test2)
@@ -8626,6 +8639,24 @@ test io-73.5 {effect of eof on encoding end flags} -setup {
removeFile io-73.5
} -result [list 1 1 more\u00a0data 1]
+test io-74.1 {[104f2885bb] improper cache validity check} -setup {
+ set fn [makeFile {} io-74.1]
+ set rfd [open $fn r]
+ testobj freeallvars
+ interp create slave
+} -constraints testobj -body {
+ teststringobj set 1 [string range $rfd 0 end]
+ read [teststringobj get 1]
+ testobj duplicate 1 2
+ interp transfer {} $rfd slave
+ catch {read [teststringobj get 1]}
+ read [teststringobj get 2]
+} -cleanup {
+ interp delete slave
+ testobj freeallvars
+ removeFile io-74.1
+} -returnCodes error -match glob -result {can not find channel named "*"}
+
# ### ### ### ######### ######### #########
# cleanup
diff --git a/tests/load.test b/tests/load.test
index 9536271..7c4b47f 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -124,9 +124,11 @@ test load-3.2 {error in _Init procedure, slave interpreter} \
test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
} {0 {}}
-test load-4.2 {reloading package into same interpreter} [list $dll $loaded] {
- list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
-} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
+test load-4.2 {reloading package into same interpreter} -setup {
+ catch {load [file join $testDir pkga$ext] pkga}
+} -constraints [list $dll $loaded] -returnCodes error -body {
+ load [file join $testDir pkga$ext] pkgb
+} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
@@ -169,26 +171,40 @@ test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] {
load {} More
set x
} {not loaded}
-test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \
- [list teststaticpkg $dll $loaded] {
- teststaticpkg Double 0 1
- teststaticpkg Double 0 1
- info loaded
- } [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
+catch {load [file join $testDir pkga$ext] pkga}
+catch {load [file join $testDir pkgb$ext] pkgb}
+catch {load [file join $testDir pkge$ext] pkge}
+set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]]
+test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup {
+ teststaticpkg Test 1 0
+ teststaticpkg Another 0 0
+ teststaticpkg More 0 1
+} -constraints [list teststaticpkg $dll $loaded] -body {
+ teststaticpkg Double 0 1
+ teststaticpkg Double 0 1
+ info loaded
+} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]
+teststaticpkg Test 1 1
+teststaticpkg Another 0 1
+teststaticpkg More 0 1
+teststaticpkg Double 0 1
test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
- info loaded
-} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
-test load-8.2 {TclGetLoadedPackages procedure} [list teststaticpkg] {
- list [catch {info loaded gorp} msg] $msg
-} {1 {could not find interpreter "gorp"}}
-test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
- list [info loaded {}] [info loaded child]
-} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
+ lsort -index 1 [info loaded]
+} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]]
+test load-8.2 {TclGetLoadedPackages procedure} -body {
+ info loaded gorp
+} -returnCodes error -result {could not find interpreter "gorp"}
+test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
+ lsort -index 1 [info loaded {}]
+} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]]
+test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
+ lsort -index 1 [info loaded child]
+} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
load [file join $testDir pkgb$ext] pkgb
- list [info loaded {}] [lsort [info commands pkgb_*]]
-} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_demo pkgb_sub pkgb_unsafe}]
+ list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]]
+} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}]
interp delete child
test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \
diff --git a/tests/msgcat.test b/tests/msgcat.test
index f50ebfb..e69220e 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -68,6 +68,7 @@ namespace eval ::msgcat::test {
set result c
}
}
+
test msgcat-0.$count [list \
locale initialization from environment variables $setVars \
] -setup {
@@ -974,6 +975,9 @@ namespace eval ::msgcat::test {
set bgerrorsaved [interp bgerror {}]
interp bgerror {} [namespace code callbackproc]
+ variable locale
+ if {![info exist locale]} { set locale [mclocale] }
+
test msgcat-14.1 {invokation loadcmd} -setup {
mcforgetpackage
mclocale $locale
@@ -1068,7 +1072,7 @@ namespace eval ::msgcat::test {
mc k1
} -returnCodes 1\
-result {fail}
-
+
interp bgerror {} $bgerrorsaved
cleanupTests
@@ -1076,3 +1080,6 @@ namespace eval ::msgcat::test {
namespace delete ::msgcat::test
return
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/namespace.test b/tests/namespace.test
index 086baf5..f6f817b 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -846,6 +846,7 @@ test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} -setup {
set ::x
}
} -result {314159}
+variable ::x 314159
test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} {
namespace eval test_ns_1 {
variable x 777
@@ -889,23 +890,25 @@ test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup {
} -result {777}
test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} {
namespace eval test_ns_1 {
+ variable x 777
unset x
set x ;# must be global x now
}
} {314159}
-test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} {
+test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body {
namespace eval test_ns_1 {
- list [catch {set wuzzat} msg] $msg
+ set wuzzat
}
-} {1 {can't read "wuzzat": no such variable}}
+} -returnCodes error -result {can't read "wuzzat": no such variable}
test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} {
namespace eval test_ns_1 {
variable a hello
}
set test_ns_1::a
} {hello}
-test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} {
+test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup {
namespace eval test_ns_1 {}
+} -body {
proc test_ns {} {
set ::test_ns_1::a 0
}
@@ -916,7 +919,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} {
namespace eval test_ns_1 set a 1
namespace delete test_ns_1
return $a
-} 1
+} -result 1
catch {unset a}
catch {unset x}
@@ -2356,6 +2359,13 @@ test namespace-50.8 {[f961d7d1dd]} -setup {
rename e {}
rename target {}
}
+test namespace-50.9 {[cea0344a51]} -body {
+ namespace eval foo {
+ namespace eval bar {
+ namespace delete foo
+ }
+ }
+} -returnCodes error -result {unknown namespace "foo" in namespace delete command}
test namespace-51.1 {name resolution path control} -body {
namespace eval ::test_ns_1 {
diff --git a/tests/obj.test b/tests/obj.test
index 7bf00f7..a8d2d20 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -26,7 +26,6 @@ testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
foreach {t} {
- {array search}
bytearray
bytecode
cmdName
diff --git a/tests/parseOld.test b/tests/parseOld.test
index a6e07a2b..504d063 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-package require tcltest
+package require tcltest 2
namespace import ::tcltest::*
::tcltest::loadTestedCommands
@@ -37,7 +37,7 @@ proc getArgs args {
global argv
set argv $args
}
-
+
# Basic argument parsing.
test parseOld-1.1 {basic argument parsing} {
@@ -296,6 +296,7 @@ test parseOld-8.4 {semi-colons} {
# The following checks are to ensure that the interpreter's result
# gets re-initialized by Tcl_Eval in all the right places.
+set a 22
test parseOld-9.1 {result initialization} {concat abc} abc
test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {}
test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {}
@@ -408,6 +409,8 @@ test parseOld-11.7 {long values} {
set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]
llength $b
} 43
+# Duplicate action of previous test
+llength [set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]]
test parseOld-11.8 {long values} {
set b
} $a
@@ -538,8 +541,12 @@ test parseOld-15.4 {TclScriptEnd procedure} {
test parseOld-15.5 {TclScriptEnd procedure} {
info complete "xyz \[abc"
} {0}
-
+
# cleanup
set argv $savedArgv
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/resolver.test b/tests/resolver.test
index f3d22e5..9bb4c08 100644
--- a/tests/resolver.test
+++ b/tests/resolver.test
@@ -187,7 +187,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
# During the compilation the compiled var resolver, the resolve-specific
# var info is allocated, during the execution of the body, the variable is
# fetched and cached.
- x;
+ x
# During later calls, the cached variable is reused.
x
# When the proc is freed, the resolver-specific resolver var info is
@@ -196,6 +196,121 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
} -cleanup {
testinterpresolver down
} -result {}
+
+
+#
+# The test resolver-3.1* test bad interactions of resolvers on the "global"
+# (per interp) literal pools. A resolver might resolve a cmd literal depending
+# on a context differently, whereas the cmd literal sharing assumed that the
+# namespace containing the literal solely determines the resolved cmd (and is
+# resolver-agnostic).
+#
+# In order to make the test cases for the per-interpreter cmd literal pool
+# reproducable and to minimize interactions between test cases, we use a slave
+# interpreter per test-case.
+#
+#
+# Testing resolver in namespace-based context "ctx1"
+#
+test resolver-3.1a {
+ interp command resolver,
+ resolve literal "z" in proc "x1" in context "ctx1"
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+ i0 eval {
+ proc y {} { return yy }
+ namespace eval ::ns {
+ proc x1 {} { z }
+ }
+ }
+} -constraints testinterpresolver -body {
+
+ set r [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ return $r
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {yy}
+
+#
+# Testing resolver in namespace-based context "ctx2"
+#
+test resolver-3.1b {
+ interp command resolver,
+ resolve literal "z" in proc "x2" in context "ctx2"
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+ i0 eval {
+ proc Y {} { return YY }
+ namespace eval ::ns {
+ proc x2 {} { z }
+ }
+ }
+} -constraints testinterpresolver -body {
+
+ set r [i0 eval {namespace eval ::ctx2 {
+ ::ns::x2
+ }}]
+
+ return $r
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {YY}
+
+#
+# Testing resolver in namespace-based context "ctx1" and "ctx2" in the same
+# interpreter.
+#
+
+test resolver-3.1c {
+ interp command resolver,
+ resolve literal "z" in proc "x1" in context "ctx1",
+ resolve literal "z" in proc "x2" in context "ctx2"
+
+ Test, whether the shared cmd literal created by the first byte-code
+ compilation interacts with the second one.
+} -setup {
+
+ interp create i0
+ testinterpresolver up i0
+
+ i0 eval {
+ proc y {} { return yy }
+ proc Y {} { return YY }
+ namespace eval ::ns {
+ proc x1 {} { z }
+ proc x2 {} { z }
+ }
+ }
+
+} -constraints testinterpresolver -body {
+
+ set r1 [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ set r2 [i0 eval {namespace eval ::ctx2 {
+ ::ns::x2
+ }}]
+
+ set r3 [i0 eval {namespace eval ::ctx1 {
+ ::ns::x1
+ }}]
+
+ return [list $r1 $r2 $r3]
+} -cleanup {
+ testinterpresolver down i0
+ interp delete i0
+} -result {yy YY yy}
+
cleanupTests
return
diff --git a/tests/safe.test b/tests/safe.test
index 94c1755..6c9c6c9 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -211,8 +211,8 @@ test safe-7.3 {check that safe subinterpreters work} {
} {ok {} 0}
# test source control on file name
+set i "a"
test safe-8.1 {safe source control on file} -setup {
- set i "a"
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
@@ -221,7 +221,6 @@ test safe-8.1 {safe source control on file} -setup {
safe::interpDelete $i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.2 {safe source control on file} -setup {
- set i "a"
catch {safe::interpDelete $i}
} -body {
safe::interpCreate $i
@@ -230,7 +229,6 @@ test safe-8.2 {safe source control on file} -setup {
safe::interpDelete $i
} -result {wrong # args: should be "source ?-encoding E? fileName"}
test safe-8.3 {safe source control on file} -setup {
- set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {lappend ::log $str}
@@ -245,7 +243,6 @@ test safe-8.3 {safe source control on file} -setup {
safe::interpDelete $i
} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}}
test safe-8.4 {safe source control on file} -setup {
- set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
@@ -260,7 +257,6 @@ test safe-8.4 {safe source control on file} -setup {
safe::interpDelete $i
} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}}
test safe-8.5 {safe source control on file} -setup {
- set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
@@ -279,7 +275,6 @@ test safe-8.5 {safe source control on file} -setup {
safe::interpDelete $i
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]]
test safe-8.6 {safe source control on file} -setup {
- set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
@@ -296,7 +291,6 @@ test safe-8.6 {safe source control on file} -setup {
safe::interpDelete $i
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]]
test safe-8.7 {safe source control on file} -setup {
- set i "a"
catch {safe::interpDelete $i}
set log {}
proc safe-test-log {str} {global log; lappend log $str}
@@ -315,7 +309,6 @@ test safe-8.7 {safe source control on file} -setup {
safe::interpDelete $i
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
test safe-8.8 {safe source forbids -rsrc} -setup {
- set i "a"
catch {safe::interpDelete $i}
safe::interpCreate $i
} -body {
@@ -349,8 +342,8 @@ test safe-8.10 {safe source and return} -setup {
removeFile $returnScript
} -result ok
+set i "a"
test safe-9.1 {safe interps' deleteHook} -setup {
- set i "a"
catch {safe::interpDelete $i}
set res {}
} -body {
@@ -365,7 +358,6 @@ test safe-9.1 {safe interps' deleteHook} -setup {
list [interp eval $i exit] $res
} -result {{} {arg1 arg2 a}}
test safe-9.2 {safe interps' error in deleteHook} -setup {
- set i "a"
catch {safe::interpDelete $i}
set res {}
set log {}
@@ -531,14 +523,14 @@ test safe-11.7.1 {testing safe encoding} -setup {
} -body {
catch {interp eval $i encoding convertfrom} m o
dict get $o -errorinfo
-} -returnCodes ok -cleanup {
+} -returnCodes ok -match glob -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"
+"::interp invokehidden interp* encoding convertfrom"
invoked from within
"encoding convertfrom"
invoked from within
@@ -555,14 +547,14 @@ test safe-11.8.1 {testing safe encoding} -setup {
} -body {
catch {interp eval $i encoding convertto} m o
dict get $o -errorinfo
-} -returnCodes ok -cleanup {
+} -returnCodes ok -match glob -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"
+"::interp invokehidden interp* encoding convertto"
invoked from within
"encoding convertto"
invoked from within
diff --git a/tests/set-old.test b/tests/set-old.test
index 0e9ca63..93169f1 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -14,7 +14,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -865,6 +865,8 @@ test set-old-10.13 {array enumeration errors} {
list [catch {array done a b c} msg] $msg
} {1 {wrong # args: should be "array donesearch arrayName searchId"}}
test set-old-10.14 {array enumeration errors} {
+ catch {unset a}
+ set a(a) a
list [catch {array done a b} msg] $msg
} {1 {illegal search identifier "b"}}
test set-old-10.15 {array enumeration errors} {
diff --git a/tests/set.test b/tests/set.test
index 7e4b864..3c87000 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -22,7 +22,7 @@ testConstraint testset2 [llength [info commands testset2]]
catch {unset x}
catch {unset i}
-
+
test set-1.1 {TclCompileSetCmd: missing variable name} {
list [catch {set} msg] $msg
} {1 {wrong # args: should be "set varName ?newValue?"}}
@@ -39,16 +39,18 @@ test set-1.4 {TclCompileSetCmd: simple variable name in quotes} {
set i 17
list [set "i"] $i
} {17 17}
-test set-1.5 {TclCompileSetCmd: simple variable name in braces} {
+test set-1.5 {TclCompileSetCmd: simple variable name in braces} -setup {
catch {unset {a simple var}}
+} -body {
set {a simple var} 27
list [set {a simple var}] ${a simple var}
-} {27 27}
-test set-1.6 {TclCompileSetCmd: simple array variable name} {
+} -result {27 27}
+test set-1.6 {TclCompileSetCmd: simple array variable name} -setup {
catch {unset a}
+} -body {
set a(foo) 37
list [set a(foo)] $a(foo)
-} {37 37}
+} -result {37 37}
test set-1.7 {TclCompileSetCmd: non-simple (computed) variable name} {
set x "i"
set i 77
@@ -149,22 +151,24 @@ test set-1.14 {TclCompileSetCmd: simple local name, >255 locals} {
}
260locals
} {1234}
-test set-1.15 {TclCompileSetCmd: variable is array} {
+test set-1.15 {TclCompileSetCmd: variable is array} -setup {
catch {unset a}
+} -body {
set x 27
set x [set a(foo) 11]
catch {unset a}
set x
-} 11
-test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} {
+} -result 11
+test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} -setup {
catch {unset a}
+} -body {
set i 5
set x 789
set a(foo5) 27
set x [set a(foo$i)]
catch {unset a}
set x
-} 27
+} -result 27
test set-1.17 {TclCompileSetCmd: doing assignment, simple int} {
set i 5
@@ -211,7 +215,7 @@ test set-1.25 {TclCompileSetCmd: var is array, braced (no subs)} {
test set-1.26 {TclCompileSetCmd: various array constructs} {
# Test all kinds of array constructs that TclCompileSetCmd
# may feel inclined to tamper with.
- proc p {} {
+ apply {{} {
set a x
set be(hej) 1 ; # hej
set be($a) 1 ; # x
@@ -230,28 +234,33 @@ test set-1.26 {TclCompileSetCmd: various array constructs} {
set [string range bet 0 1](foo) 1 ; # foo
set be([set be(a:$a)][set b\e($a)]) 1 ; # 51
return [lsort [array names be]]
- }
- p
+ }}
} [lsort {hej x $a x,hej x,x c(x ww a:x hej,1,hej hug {a a} {x ,ugg,hej} x,h"ej
{b c} foo 51}]; # " just a matching end quote
-test set-2.1 {set command: runtime error, bad variable name} {
+test set-2.1 {set command: runtime error, bad variable name} -setup {
unset -nocomplain {"foo}
+} -body {
list [catch {set {"foo}} msg] $msg $::errorInfo
-} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
+} -result {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
while executing
"set {"foo}"}}
-test set-2.2 {set command: runtime error, not array variable} {
- catch {unset b}
+# Stop my editor highlighter " from being confused
+test set-2.2 {set command: runtime error, not array variable} -setup {
+ unset -nocomplain b
+} -body {
set b 44
list [catch {set b(123)} msg] $msg
-} {1 {can't read "b(123)": variable isn't array}}
-test set-2.3 {set command: runtime error, errors in reading variables} {
- catch {unset a}
+} -result {1 {can't read "b(123)": variable isn't array}}
+test set-2.3 {set command: runtime error, errors in reading variables} -setup {
+ unset -nocomplain a
+} -body {
set a(6) 44
list [catch {set a(18)} msg] $msg
-} {1 {can't read "a(18)": no such element in array}}
-test set-2.4 {set command: runtime error, readonly variable} -body {
+} -result {1 {can't read "a(18)": no such element in array}}
+test set-2.4 {set command: runtime error, readonly variable} -setup {
+ unset -nocomplain x
+} -body {
proc readonly args {error "variable is read-only"}
set x 123
trace var x w readonly
@@ -260,12 +269,18 @@ test set-2.4 {set command: runtime error, readonly variable} -body {
while executing
*
"set x 1"}}
-test set-2.5 {set command: runtime error, basic array operations} {
+test set-2.5 {set command: runtime error, basic array operations} -setup {
+ unset -nocomplain a
+} -body {
+ array set a {}
list [catch {set a(other)} msg] $msg
-} {1 {can't read "a(other)": no such element in array}}
-test set-2.6 {set command: runtime error, basic array operations} {
+} -result {1 {can't read "a(other)": no such element in array}}
+test set-2.6 {set command: runtime error, basic array operations} -setup {
+ unset -nocomplain a
+} -body {
+ array set a {}
list [catch {set a} msg] $msg
-} {1 {can't read "a": variable is array}}
+} -result {1 {can't read "a": variable is array}}
# Test the uncompiled version of set
@@ -479,25 +494,29 @@ test set-3.24 {uncompiled set command: too many arguments} {
$z msg
} {wrong # args: should be "set varName ?newValue?"}
-test set-4.1 {uncompiled set command: runtime error, bad variable name} {
+test set-4.1 {uncompiled set command: runtime error, bad variable name} -setup {
unset -nocomplain {"foo}
+} -body {
set z set
list [catch {$z {"foo}} msg] $msg $::errorInfo
-} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
+} -result {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable
while executing
"$z {"foo}"}}
-test set-4.2 {uncompiled set command: runtime error, not array variable} {
- set z set
+# Stop my editor highlighter " from being confused
+test set-4.2 {uncompiled set command: runtime error, not array variable} -setup {
catch {unset b}
+} -body {
+ set z set
$z b 44
list [catch {$z b(123)} msg] $msg
-} {1 {can't read "b(123)": variable isn't array}}
-test set-4.3 {uncompiled set command: runtime error, errors in reading variables} {
- set z set
- catch {unset a}
+} -result {1 {can't read "b(123)": variable isn't array}}
+test set-4.3 {uncompiled set command: runtime error, errors in reading variables} -setup {
+ catch {unset a}
+} -body {
+ set z set
$z a(6) 44
list [catch {$z a(18)} msg] $msg
-} {1 {can't read "a(18)": no such element in array}}
+} -result {1 {can't read "a(18)": no such element in array}}
test set-4.4 {uncompiled set command: runtime error, readonly variable} -body {
set z set
proc readonly args {error "variable is read-only"}
@@ -508,27 +527,33 @@ test set-4.4 {uncompiled set command: runtime error, readonly variable} -body {
while executing
*
"$z x 1"}}
-test set-4.5 {uncompiled set command: runtime error, basic array operations} {
+test set-4.5 {uncompiled set command: runtime error, basic array operations} -setup {
+ unset -nocomplain a
+ array set a {}
+} -body {
set z set
list [catch {$z a(other)} msg] $msg
-} {1 {can't read "a(other)": no such element in array}}
-test set-4.6 {set command: runtime error, basic array operations} {
+} -result {1 {can't read "a(other)": no such element in array}}
+test set-4.6 {set command: runtime error, basic array operations} -setup {
+ unset -nocomplain a
+ array set a {}
+} -body {
set z set
list [catch {$z a} msg] $msg
-} {1 {can't read "a": variable is array}}
+} -result {1 {can't read "a": variable is array}}
-test set-5.1 {error on malformed array name} testset2 {
+test set-5.1 {error on malformed array name} -constraints testset2 -setup {
unset -nocomplain z
+} -body {
catch {testset2 z(a) b} msg
catch {testset2 z(b) a} msg1
list $msg $msg1
-} {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}}
-
+} -result {{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}
@@ -537,3 +562,7 @@ catch {unset x}
catch {unset z}
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/socket.test b/tests/socket.test
index 8473602..d43c41c 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1782,7 +1782,6 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
set i 0
vwait x
close $f
- thread::wait
}]]
set port [thread::send $serverthread {set listen}]
set s [socket $localhost $port]
diff --git a/tests/tcltest.test b/tests/tcltest.test
index e66678b..728a018 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -46,6 +46,7 @@ makeFile {
cd [temporaryDirectory]
testConstraint exec [llength [info commands exec]]
+
# test -help
# Child processes because -help [exit]s.
test tcltest-1.1 {tcltest -help} {exec} {
@@ -1824,9 +1825,13 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup {
---- errorInfo: body error
*
---- errorInfo(cleanup): cleanup error*}
-
+
cleanupTests
}
namespace delete ::tcltest::test
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/unload.test b/tests/unload.test
index 5a374c4..73f1091 100644
--- a/tests/unload.test
+++ b/tests/unload.test
@@ -45,6 +45,14 @@ testConstraint teststaticpkg [llength [info commands teststaticpkg]]
testConstraint testsimplefilesystem \
[llength [info commands testsimplefilesystem]]
+proc loadIfNotPresent {pkg args} {
+ global testDir ext
+ set loaded [lmap x [info loaded {*}$args] {lindex $x 1}]
+ if {[string totitle $pkg] ni $loaded} {
+ load [file join $testDir $pkg$ext]
+ }
+}
+
# Basic tests: parameter testing...
test unload-1.1 {basic errors} -returnCodes error -body {
unload
@@ -73,7 +81,7 @@ set pkgua_detached {}
set pkgua_unloaded {}
# Tests for loading/unloading in trusted (non-safe) interpreters...
test unload-2.1 {basic loading of non-unloadable package, with guess for package name} [list $dll $loaded] {
- load [file join $testDir pkga$ext]
+ loadIfNotPresent pkga
list [pkga_eq abc def] [lsort [info commands pkga_*]]
} {0 {pkga_eq pkga_quote}}
test unload-2.2 {basic loading of unloadable package, with guess for package name} [list $dll $loaded] {
@@ -82,28 +90,43 @@ test unload-2.2 {basic loading of unloadable package, with guess for package nam
[pkgua_eq abc def] [lsort [info commands pkgua_*]] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
} {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}}
-test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} [list $dll $loaded] {
- list [catch {unload [file join $testDir pkga$ext]} msg] \
- [string map [list [file join $testDir pkga$ext] file] $msg]
-} {1 {file "file" cannot be unloaded under a trusted interpreter}}
-test unload-2.4 {basic unloading of unloadable package, with guess for package name} [list $dll $loaded] {
+test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} -setup {
+ loadIfNotPresent pkga
+} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
+ unload [file join $testDir pkga$ext]
+} -result {file "*" cannot be unloaded under a trusted interpreter}
+test unload-2.4 {basic unloading of unloadable package, with guess for package name} -setup {
+ loadIfNotPresent pkgua
+} -constraints [list $dll $loaded] -body {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
[unload [file join $testDir pkgua$ext]] \
[info commands pkgua_*] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
-} {. {} {} {} {} . . .}
-test unload-2.5 {reloading of unloaded package, with guess for package name} [list $dll $loaded] {
+} -result {. {} {} {} {} . . .}
+test unload-2.5 {reloading of unloaded package, with guess for package name} -setup {
+ if {$pkgua_loaded eq ""} {
+ loadIfNotPresent pkgua
+ unload [file join $testDir pkgua$ext]
+ }
+} -constraints [list $dll $loaded] -body {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
[load [file join $testDir pkgua$ext]] \
[pkgua_eq abc def] [lsort [info commands pkgua_*]] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
-} {. . . {} 0 {pkgua_eq pkgua_quote} .. . .}
-test unload-2.6 {basic unloading of re-loaded package, with guess for package name} [list $dll $loaded] {
+} -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .}
+test unload-2.6 {basic unloading of re-loaded package, with guess for package name} -setup {
+ # Establish expected state
+ if {$pkgua_loaded eq ""} {
+ loadIfNotPresent pkgua
+ unload [file join $testDir pkgua$ext]
+ load [file join $testDir pkgua$ext]
+ }
+} -constraints [list $dll $loaded] -body {
list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
[unload [file join $testDir pkgua$ext]] \
[info commands pkgua_*] \
$pkgua_loaded $pkgua_detached $pkgua_unloaded
-} {.. . . {} {} .. .. ..}
+} -result {.. . . {} {} .. .. ..}
# Tests for loading/unloading in safe interpreters...
interp create -safe child
@@ -127,38 +150,52 @@ test unload-3.2 {basic loading of unloadable package in a safe interpreter, with
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
-test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} \
- [list $dll $loaded] {
- list [catch {unload [file join $testDir pkga$ext] {} child} msg] \
- [string map [list [file join $testDir pkga$ext] file] $msg]
-} {1 {file "file" has never been loaded in this interpreter}}
-test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} \
- [list $dll $loaded] {
- list [catch {unload [file join $testDir pkgb$ext] {} child} msg] \
- [string map [list [file join $testDir pkgb$ext] file] $msg]
-} {1 {file "file" cannot be unloaded under a safe interpreter}}
-test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} \
- [list $dll $loaded] {
+test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup {
+ loadIfNotPresent pkga
+} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
+ unload [file join $testDir pkga$ext] {} child
+} -result {file "*" has never been loaded in this interpreter}
+test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup {
+ if {[lsearch -index 1 [info loaded child] Pkgb] == -1} {
+ load [file join $testDir pkgb$ext] pKgB child
+ }
+} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
+ unload [file join $testDir pkgb$ext] {} child
+} -result {file "*" cannot be unloaded under a safe interpreter}
+test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup {
+ if {[lsearch -index 1 [info loaded child] Pkgua] == -1} {
+ load [file join $testDir pkgua$ext] pkgua child
+ }
+} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[unload [file join $testDir pkgua$ext] {} child] \
[child eval info commands pkgua_*] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
-} {{. {} {}} {} {} {. . .}}
-test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} \
- [list $dll $loaded] {
+} -result {{. {} {}} {} {} {. . .}}
+test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} -setup {
+ if {[child eval set pkgua_loaded] eq ""} {
+ load [file join $testDir pkgua$ext] {} child
+ unload [file join $testDir pkgua$ext] {} child
+ }
+} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[load [file join $testDir pkgua$ext] {} child] \
[child eval pkgua_eq abc def] \
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
-} {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}}
-test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} \
- [list $dll $loaded] {
+} -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}}
+test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} -setup {
+ if {[child eval set pkgua_loaded] eq ""} {
+ load [file join $testDir pkgua$ext] {} child
+ unload [file join $testDir pkgua$ext] {} child
+ load [file join $testDir pkgua$ext] {} child
+ }
+} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[unload [file join $testDir pkgua$ext] pKgUa child] \
[child eval info commands pkgua_*] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
-} {{.. . .} {} {} {.. .. ..}}
+} -result {{.. . .} {} {} {.. .. ..}}
# Tests for loading/unloading of a package among multiple interpreters...
interp create child-trusted
@@ -167,56 +204,89 @@ child-trusted eval {
set pkgua_detached {}
set pkgua_unloaded {}
}
+array set load {M 0 C 0 T 0}
## Load package in main trusted interpreter...
-test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} \
- [list $dll $loaded] {
+test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} -setup {
+ set pkgua_loaded ""
+ set pkgua_detached ""
+ set pkgua_unloaded ""
+ incr load(M)
+} -constraints [list $dll $loaded] -body {
list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \
[load [file join $testDir pkgua$ext]] \
[pkgua_eq abc def] [lsort [info commands pkgua_*]] \
[list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
-} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}}
+} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Load package in child-safe interpreter...
-test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \
- [list $dll $loaded] {
+test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} -setup {
+ child eval {
+ set pkgua_loaded ""
+ set pkgua_detached ""
+ set pkgua_unloaded ""
+ }
+ incr load(C)
+} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[load [file join $testDir pkgua$ext] pKgUA child] \
[child eval pkgua_eq abc def] \
[lsort [child eval info commands pkgua_*]] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
-} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}}
+} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Load package in child-trusted interpreter...
-test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} \
- [list $dll $loaded] {
+test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} -setup {
+ incr load(T)
+} -constraints [list $dll $loaded] -body {
list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[load [file join $testDir pkgua$ext] pkguA child-trusted] \
[child-trusted eval pkgua_eq abc def] \
[lsort [child-trusted eval info commands pkgua_*]] \
[child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
-} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
+} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
## Unload the package from the main trusted interpreter...
-test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} \
- [list $dll $loaded] {
+test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} -setup {
+ if {!$load(M)} {
+ load [file join $testDir pkgua$ext]
+ }
+ if {!$load(C)} {
+ load [file join $testDir pkgua$ext] {} child
+ incr load(C)
+ }
+ if {!$load(T)} {
+ load [file join $testDir pkgua$ext] {} child-trusted
+ incr load(T)
+ }
+} -constraints [list $dll $loaded] -body {
list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \
[unload [file join $testDir pkgua$ext]] \
[info commands pkgua_*] \
[list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
-} {{... .. ..} {} {} {... ... ..}}
+} -result {{. {} {}} {} {} {. . {}}}
## Unload the package from the child safe interpreter...
-test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \
- [list $dll $loaded] {
+test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup {
+ if {!$load(C)} {
+ load [file join $testDir pkgua$ext] {} child
+ }
+ if {!$load(T)} {
+ load [file join $testDir pkgua$ext] {} child-trusted
+ incr load(T)
+ }
+} -constraints [list $dll $loaded] -body {
list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[unload [file join $testDir pkgua$ext] {} child] \
[child eval info commands pkgua_*] \
[child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
-} {{... .. ..} {} {} {... ... ..}}
+} -result {{. {} {}} {} {} {. . {}}}
## Unload the package from the child trusted interpreter...
-test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \
- [list $dll $loaded] {
+test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup {
+ if {!$load(T)} {
+ load [file join $testDir pkgua$ext] {} child-trusted
+ }
+} -constraints [list $dll $loaded] -body {
list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
[unload [file join $testDir pkgua$ext] {} child-trusted] \
[child-trusted eval info commands pkgua_*] \
[child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
-} {{. {} {}} {} {} {. . .}}
+} -result {{. {} {}} {} {} {. . .}}
test unload-5.1 {unload a module loaded from vfs} \
-constraints [list $dll $loaded testsimplefilesystem] \
@@ -230,9 +300,7 @@ test unload-5.1 {unload a module loaded from vfs} \
list [catch {unload simplefs:/pkgua$ext} msg] $msg
} \
-result {0 {}}
-
-
-
+
# cleanup
interp delete child
interp delete child-trusted
diff --git a/tests/var.test b/tests/var.test
index 6f90664..9816d98 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -26,6 +26,21 @@ testConstraint testupvar [llength [info commands testupvar]]
testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
testConstraint testsetnoerr [llength [info commands testsetnoerr]]
testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc getbytes {} {
+ return [lindex [split [memory info] \n] 3 3]
+ }
+ proc leaktest {script {iterations 3}} {
+ set end [getbytes]
+ for {set i 0} {$i < $iterations} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [getbytes]
+ }
+ return [expr {$end - $tmp}]
+ }
+}
+
catch {rename p ""}
catch {namespace delete test_ns_var}
@@ -44,10 +59,12 @@ test var-1.1 {TclLookupVar, Array handling} -setup {
set arr(foo) 37
list [$x i] $i [$x arr(foo)] $arr(foo)
} -result {11 11 38 38}
+set ::x "global value"
+namespace eval test_ns_var {
+ variable x "namespace value"
+}
test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {
- set x "global value"
namespace eval test_ns_var {
- variable x "namespace value"
proc p {} {
global x ;# specifies TCL_GLOBAL_ONLY to get global x
return $x
@@ -167,7 +184,9 @@ test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array:
set result
}
} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
-test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} {
+test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup {
+ unset -nocomplain test_ns_var::x
+} -body {
namespace eval test_ns_var {
variable result {}
variable x
@@ -179,7 +198,7 @@ test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array:
namespace delete [namespace current]
set result
}
-} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
+} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
test var-1.19 {TclLookupVar, right error message when parsing variable name} -body {
[format set] thisvar(doesntexist)
} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable}
@@ -261,6 +280,7 @@ test var-3.7 {MakeUpvar, my var has ::s} -setup {
}
} -result {789789}
test var-3.8 {MakeUpvar, my var already exists in global ns} -setup {
+ upvar #0 aaaaa xxxxx
catch {unset aaaaa}
catch {unset xxxxx}
} -body {
@@ -274,6 +294,8 @@ test var-3.9 {MakeUpvar, my var has invalid ns name} -setup {
} -returnCodes error -body {
set aaaaa 789789
upvar #0 aaaaa test_ns_fred::lnk
+} -cleanup {
+ unset ::aaaaa
} -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist}
test var-3.10 {MakeUpvar, between namespaces} -body {
namespace eval {} {
@@ -282,8 +304,6 @@ test var-3.10 {MakeUpvar, between namespaces} -body {
set foo::bar 1
list $bar $foo::bar
}
-} -cleanup {
- unset ::aaaaa
} -result {1 1}
test var-3.11 {MakeUpvar, my var looks like array elem} -setup {
catch {unset aaaaa}
@@ -322,9 +342,11 @@ test var-5.2 {Tcl_GetVariableFullName, namespace variable} {
namespace which -variable martha
}
} {::test_ns_var::martha}
-test var-5.3 {Tcl_GetVariableFullName, namespace variable} {
+test var-5.3 {Tcl_GetVariableFullName, namespace variable} -setup {
+ namespace eval test_ns_var {variable martha}
+} -body {
namespace which -variable test_ns_var::martha
-} {::test_ns_var::martha}
+} -result {::test_ns_var::martha}
test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
namespace eval test_ns_var {
@@ -348,6 +370,7 @@ test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
test_ns_var::p
} {java}
test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} {
+ namespace eval ::test_ns_var::test_ns_nested {}
set ::test_ns_var::test_ns_nested:: 24
apply {{} {
global ::test_ns_var::test_ns_nested::
@@ -389,20 +412,26 @@ test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
}
list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
} {0 1 {can't read "test_ns_var::two": no such variable}}
-test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} {
+test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} -setup {
+ catch {namespace delete test_ns_var}
+ namespace eval test_ns_var {variable one 1}
+} -body {
namespace eval test_ns_var {
variable two 2
}
list [lsort [info vars test_ns_var::*]] \
[namespace eval test_ns_var {set two}]
-} [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]
-test var-7.4 {Tcl_VariableObjCmd, list of vars} {
+} -result [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]
+test var-7.4 {Tcl_VariableObjCmd, list of vars} -setup {
+ catch {namespace delete test_ns_var}
+ namespace eval test_ns_var {variable one 1; variable two 2}
+} -body {
namespace eval test_ns_var {
variable three 3 four 4
}
list [lsort [info vars test_ns_var::*]] \
[namespace eval test_ns_var {expr $three+$four}]
-} [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7]
+} -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7]
test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup {
catch {unset a}
catch {unset five}
@@ -476,7 +505,9 @@ test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until na
[lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\
{1 {can't unset "test_ns_var2::z": no such variable}}\
{}]
-test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
+test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup {
+ namespace eval test_ns_var { variable eight 8 }
+} -body {
namespace eval test_ns_var {
proc p {} {
variable eight
@@ -484,14 +515,16 @@ test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link v
}
p
}
-} {8 eight}
-test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
+} -result {8 eight}
+test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup {
+ namespace eval test_ns_var { variable eight 8 }
+} -body {
proc p {} { ;# note this proc is at global :: scope
variable test_ns_var::eight
list [set eight] [info vars]
}
p
-} {8 eight}
+} -result {8 eight}
test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
namespace eval test_ns_var {
variable {} {My name is empty}
@@ -561,6 +594,22 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit
list [namespace delete test_ns_var] $::info
} -result {{} {::test_ns_var::v {} u}}
+test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup {
+ proc ::t {a i o} {
+ set $a 321
+ }
+} -body {
+ leaktest {
+ namespace eval n {
+ variable v 123
+ trace variable v u ::t
+ }
+ namespace delete n
+ }
+} -cleanup {
+ rename ::t {}
+} -result 0
+
test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup {
catch {unset u}
catch {unset v}
@@ -774,7 +823,7 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup {
test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
set already 0
- unset x
+ unset -nocomplain x
} -body {
array set x {e 1 i 1}
trace add variable x unset {apply {args {
@@ -896,9 +945,6 @@ test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
} -result 1
test var-22.0 {leak in array element unset: Bug a3309d01db} -setup {
- proc getbytes {} {
- lindex [split [memory info] \n] 3 3
- }
proc doit k {
variable A
set A($k) {}
@@ -918,13 +964,9 @@ test var-22.0 {leak in array element unset: Bug a3309d01db} -setup {
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
- rename getbytes {}
rename doit {}
} -result 0
test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup {
- proc getbytes {} {
- lindex [split [memory info] \n] 3 3
- }
proc doit {} {
interp create slave
slave eval {
@@ -946,15 +988,21 @@ test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup {
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
array unset A
- rename getbytes {}
rename doit {}
} -result 0
+test var-22.2 {leak in parsedVarName} -constraints memory -body {
+ set i 0
+ leaktest {lappend x($i)}
+} -cleanup {
+ unset -nocomplain i x
+} -result 0
catch {namespace delete ns}
catch {unset arr}
catch {unset v}
+catch {rename getbytes ""}
catch {rename p ""}
catch {namespace delete test_ns_var}
catch {namespace delete test_ns_var2}
diff --git a/tests/zlib.test b/tests/zlib.test
index c9e5f10..15dbb34 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -251,9 +251,10 @@ test zlib-8.8 {transformation and fconfigure} -setup {
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
- fconfigure $inSide -blocking 0 -translation binary
+ fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
+ chan close $outSide
set compressed [read $inSide]
catch {zlib decompress $compressed} err opt
list [string length [zlib compress $spdyHeaders]] \
@@ -269,10 +270,11 @@ test zlib-8.9 {transformation and fconfigure} -setup {
} -constraints zlib -body {
zlib push compress $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
- fconfigure $inSide -blocking 0 -translation binary
+ fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
set result [fconfigure $outSide -checksum]
chan pop $outSide
+ chan close $outSide
$strm put -dictionary $spdyDict [read $inSide]
lappend result [string length $spdyHeaders] [string length [$strm get]]
} -cleanup {
@@ -285,9 +287,10 @@ test zlib-8.10 {transformation and fconfigure} -setup {
} -constraints {zlib recentZlib} -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
- fconfigure $inSide -blocking 0 -translation binary
+ fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
+ chan close $outSide
set compressed [read $inSide]
catch {
zlib inflate $compressed
@@ -306,9 +309,10 @@ test zlib-8.11 {transformation and fconfigure} -setup {
} -constraints zlib -body {
zlib push deflate $outSide -dictionary $spdyDict
fconfigure $outSide -blocking 0 -translation binary -buffering none
- fconfigure $inSide -blocking 0 -translation binary
+ fconfigure $inSide -blocking 1 -translation binary
puts -nonewline $outSide $spdyHeaders
chan pop $outSide
+ chan close $outSide
$strm put -dictionary $spdyDict [read $inSide]
list [string length $spdyHeaders] [string length [$strm get]]
} -cleanup {
@@ -913,6 +917,29 @@ test zlib-12.1 {Tk Bug 9eb55debc5} -constraints zlib -setup {
} -cleanup {
$stream close
} -result {12026 18000}
+test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup {
+ set filesrc [makeFile {} test.input]
+ set filedst [makeFile {} test.output]
+ set f [open $filesrc "wb"]
+ for {set i 0} {$i < 10000} {incr i} {
+ puts -nonewline $f "x"
+ }
+ close $f
+} -body {
+ set fin [open $filesrc "rb"]
+ set fout [open $filedst "wb"]
+ set header [dict create filename "test.input" time 0]
+ try {
+ fcopy $fin [zlib push gzip $fout -header $header]
+ } finally {
+ close $fin
+ close $fout
+ }
+ file size $filedst
+} -cleanup {
+ removeFile $filesrc
+ removeFile $filedst
+} -result 4152
::tcltest::cleanupTests
return
generated by cgit v0.12 at 2025-08-15 21:51:25 (GMT)