diff options
Diffstat (limited to 'tests')
41 files changed, 1603 insertions, 389 deletions
diff --git a/tests/all.tcl b/tests/all.tcl index 0a6f57f..69a16ba 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package prefer latest -package require Tcl 8.5 +package require Tcl 8.5- package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] diff --git a/tests/binary.test b/tests/binary.test index 40b1315..7738f69 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2837,6 +2837,19 @@ test binary-76.2 {binary string appending growth algorithm} win { # Append to it string length [append str [binary format a* foo]] } 3 + +test binary-77.1 {string cat ops on all bytearrays} { + apply {{a b} { + return [binary format H* $a][binary format H* $b] + }} ab cd +} [binary format H* abcd] +test binary-77.2 {string cat ops on all bytearrays} { + apply {{a b} { + set one [binary format H* $a] + return $one[binary format H* $b] + }} ab cd +} [binary format H* abcd] + # ---------------------------------------------------------------------- # cleanup 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 64cfeba..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,20 +882,20 @@ 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 gorpexe [makeFile foo gorp.exe] - lappend x [file exe $gorpexe] -} -cleanup { - removeFile $gorpexe -} -result {0 1} -test cmdAH-18.5.1 {Tcl_FileObjCmd: executable} -constraints {win} -body { - # On pc, must be a .exe, .com, etc. - set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe [string toupper $gorpexe]] + set x {} + set gorpexes {} + 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]] + } + set x } -cleanup { - removeFile $gorpexe -} -result {0 1} + foreach gorpexe $gorpexes { + removeFile $gorpexe + } +} -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 @@ -1027,6 +1031,16 @@ test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} -setup { set modatime [file atime $file $newatime] expr {$newatime == $modatime ? 1 : "$newatime != $modatime"} } -result 1 +test cmdAH-20.7 { + Tcl_FileObjCmd: atime (built-in Windows names) +} -constraints {win} -body { + file atime con +} -result "could not get access time for file \"con\"" -returnCodes error +test cmdAH-20.7.1 { + Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension) +} -constraints {win} -body { + file atime [file join [temporaryDirectory] CON.txt] +} -result "could not get access time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error if {[testConstraint unix] && [file exists /tmp]} { removeFile touch.me /tmp @@ -1258,6 +1272,16 @@ test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} -setup { } -cleanup { file delete -force $dirname } -result {0 1} +test cmdAH-24.14 { + Tcl_FileObjCmd: mtime (built-in Windows names) +} -constraints {win} -body { + file mtime con +} -result "could not get modification time for file \"con\"" -returnCodes error +test cmdAH-24.14.1 { + Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension) +} -constraints {win} -body { + file mtime [file join [temporaryDirectory] CON.txt] +} -result "could not get modification time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body { @@ -1277,6 +1301,12 @@ test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} { file owned / } 0 +test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body { + file owned $env(windir) +} -result 0 +test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body { + file owned nosuchfile +} -result 0 # readlink test cmdAH-26.1 {Tcl_FileObjCmd: readlink} -returnCodes error -body { @@ -1307,6 +1337,16 @@ test cmdAH-27.2 {Tcl_FileObjCmd: size} { test cmdAH-27.3 {Tcl_FileObjCmd: size} { list [catch {file size _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} +test cmdAH-27.4 { + Tcl_FileObjCmd: size (built-in Windows names) +} -constraints {win} -body { + file size con +} -result 0 +test cmdAH-27.4.1 { + Tcl_FileObjCmd: size (built-in Windows names with dir path and extension) +} -constraints {win} -body { + file size [file join [temporaryDirectory] con.txt] +} -result 0 catch {testsetplatform $platform} removeFile $gorpfile @@ -1398,12 +1438,24 @@ test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup { } -cleanup { removeFile $filename } -result 1 +test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { + unset -nocomplain stat +} -body { + file stat con stat + lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} +} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} +test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { + unset -nocomplain stat +} -body { + file stat [file join [temporaryDirectory] CON.txt] stat + lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} +} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} unset -nocomplain stat # type test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body { - file size a b -} -result {wrong # args: should be "file size name"} + file type a b +} -result {wrong # args: should be "file type name"} test cmdAH-29.2 {Tcl_FileObjCmd: type} { file type $dirfile } directory @@ -1438,6 +1490,16 @@ test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup { test cmdAH-29.5 {Tcl_FileObjCmd: type} { list [catch {file type _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} +test cmdAH-29.6 { + Tcl_FileObjCmd: type (built-in Windows names) +} -constraints {win} -body { + file type con +} -result "characterSpecial" +test cmdAH-29.6.1 { + Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension) +} -constraints {win} -body { + file type [file join [temporaryDirectory] CON.txt] +} -result "characterSpecial" # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { diff --git a/tests/compile.test b/tests/compile.test index 6aa7fd1..2fa4147 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -678,7 +678,7 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup # change without warning. set disassemblables [linsert [join { - lambda method objmethod proc script + constructor destructor lambda method objmethod proc script } ", "] end-1 or] test compile-18.1 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble @@ -872,6 +872,103 @@ test compile-18.39 {disassembler - basics} -setup { } -cleanup { foo destroy } -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.40 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble constructor +} -match glob -result {wrong # args: should be "* constructor className"} +test compile-18.41 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble constructor nosuchclass +} -result {nosuchclass does not refer to an object} +test compile-18.42 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble constructor justanobject +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.43 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::disassemble constructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined constructor} +test compile-18.44 {disassembler - basics} -setup { + oo::class create foo {constructor {} {set x 1}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble constructor foo +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.45 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode constructor +} -match glob -result {wrong # args: should be "* constructor className"} +test compile-18.46 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode constructor nosuchobject +} -result {nosuchobject does not refer to an object} +test compile-18.47 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::getbytecode constructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined constructor} +test compile-18.48 {disassembler - basics} -setup { + oo::class create foo {constructor {} {set x 1}} +} -body { + dict keys [tcl::unsupported::getbytecode constructor foo] +} -cleanup { + foo destroy +} -result "$bytecodekeys" +# There is no compile-18.49 +test compile-18.50 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble destructor +} -match glob -result {wrong # args: should be "* destructor className"} +test compile-18.51 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble destructor nosuchclass +} -result {nosuchclass does not refer to an object} +test compile-18.52 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble destructor justanobject +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.53 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::disassemble destructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined destructor} +test compile-18.54 {disassembler - basics} -setup { + oo::class create foo {destructor {set x 1}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble destructor foo +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.55 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode destructor +} -match glob -result {wrong # args: should be "* destructor className"} +test compile-18.56 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode destructor nosuchobject +} -result {nosuchobject does not refer to an object} +test compile-18.57 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::getbytecode destructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined destructor} +test compile-18.58 {disassembler - basics} -setup { + oo::class create foo {destructor {set x 1}} +} -body { + dict keys [tcl::unsupported::getbytecode destructor foo] +} -cleanup { + foo destroy +} -result "$bytecodekeys" test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { # This will panic in a --enable-symbols=compile build, unless bug is fixed. diff --git a/tests/dict.test b/tests/dict.test index d5406d0..a6b0cb4 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2048,6 +2048,13 @@ test dict-24.25 {dict map with huge dict (compiled)} { }} 100000 } 166666666600000 +test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} { + # Test crashes on failure + apply {{} { + lassign {} item + dict update item item item two two {} + }} +} {} # cleanup ::tcltest::cleanupTests 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/event.test b/tests/event.test index 0d1b06c..ef0947f 100644 --- a/tests/event.test +++ b/tests/event.test @@ -583,6 +583,34 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { removeFile $test2file list $x $y $z } {3 3 done} +test event-11.7 {Bug 16828b3744} { + after idle { + set ::t::v 1 + namespace delete ::t + } + namespace eval ::t { + vwait ::t::v + } +} {} +test event-11.8 {Bug 16828b3744} -setup { + oo::class create A { + variable continue + + method start {} { + after idle [self] destroy + + set continue 0 + vwait [namespace current]::continue + } + destructor { + set continue 1 + } + } +} -body { + [A new] start +} -cleanup { + A destroy +} -result {} test event-12.1 {Tcl_UpdateCmd procedure} -returnCodes error -body { update a b diff --git a/tests/exec.test b/tests/exec.test index 16a8320..2a4b31e 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -682,6 +682,19 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { } -cleanup { removeFile $tmpfile } -result 14 + +# Tests to ensure batch files and .CMD (Bug 9ece99d58b) +# can be executed on Windows +test exec-20.0 {exec .bat file} -constraints {win} -body { + set log [makeFile {} exec20.log] + exec [makeFile "echo %1> $log" exec20.bat] "Testing exec-20.0" + viewFile $log +} -result "\"Testing exec-20.0\"" +test exec-20.1 {exec .CMD file} -constraints {win} -body { + set log [makeFile {} exec201.log] + 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 51f00d1..387d844 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -1468,14 +1468,16 @@ if {[testConstraint testsetplatform]} { } test filename-17.2 {windows specific glob with executable} -body { makeDirectory execglob - makeFile contents execglob/abc.exe - makeFile contents execglob/abc.notexecutable - glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x * + foreach ext {exe com cmd bat notexecutable} { + makeFile contents execglob/abc.$ext + } + lsort [glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x *] } -constraints {win} -cleanup { - removeFile execglob/abc.exe - removeFile execglob/abc.notexecutable + foreach ext {exe com cmd bat ps1 notexecutable} { + removeFile execglob/abc.$ext + } removeDirectory execglob -} -result {abc.exe} +} -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/for.test b/tests/for.test index 8e701d6..c8a8187 100644 --- a/tests/for.test +++ b/tests/for.test @@ -451,7 +451,7 @@ proc formatMail {} { set c [string length $line] } } - set newline [string range $line 0 $c] + set newline [string trimright [string range $line 0 $c]] if {! $continuation} { append result $newline $NL } else { @@ -507,7 +507,7 @@ releases of the Tcl scripting language and the Tk toolk it. The first beta versions of these releases were released on August 30, 1996. These releas es contain only minor changes, -so we hope to have only a single beta release and to +so we hope to have only a single beta release and to go final in early October, 1996. @@ -519,34 +519,34 @@ and changes files in the distributions for more complet e information on what has changed, including both feature changes and bug fixes. - There are new options to the file command for + There are new options to the file command for copying files (file copy), - deleting files and directories (file delete), + deleting files and directories (file delete), creating directories (file mkdir), and renaming files (file rename). The implementation of exec has been improved great ly for Windows 95 and Windows NT. - There is a new memory allocator for the Macintosh + There is a new memory allocator for the Macintosh version, which should be more efficient than the old one. - Tk's grid geometry manager has been completely + Tk's grid geometry manager has been completely rewritten. The layout algorithm produces much better layouts than before , especially where rows or columns were stretchable. - There are new commands for creating common dialog + There are new commands for creating common dialog boxes: tk_chooseColor, tk_getOpenFile, tk_getSaveFile and - tk_messageBox. These use native dialog boxes if + tk_messageBox. These use native dialog boxes if they are available. There is a new virtual event mechanism for handlin g events in a more portable - way. See the new command event. It also allows + way. See the new command event. It also allows events (both physical and virtual) to be generated dynamically. -Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl +Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for changes in the C APIs for custom channel drivers. Scrip ts written for earlier releases @@ -556,27 +556,27 @@ Obtaining The Releases Binary Releases -Pre-compiled releases are available for the following +Pre-compiled releases are available for the following platforms: Windows 3.1, Windows 95, and Windows NT: Fetch - ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then + ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a - self-extracting executable. It will install the + self-extracting executable. It will install the Tcl and Tk libraries, the wish and tclsh programs, and documentation. Macintosh (both 68K and PowerPC): Fetch - ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. + ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format, - which is understood by Fetch, StuffIt, and many + which is understood by Fetch, StuffIt, and many other Mac utilities. The - unpacked file is a self-installing executable: + unpacked file is a self-installing executable: double-click on it and it will create a - folder containing all that you need to run Tcl + folder containing all that you need to run Tcl and Tk. - UNIX (Solaris 2.* and SunOS, other systems + UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install - binary packages are now for sale at the Sun Labs + binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out! } diff --git a/tests/format.test b/tests/format.test index 27eac31..e199398 100644 --- a/tests/format.test +++ b/tests/format.test @@ -564,9 +564,12 @@ test format-19.3 {Bug 2830354} { test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { set x [dict create a b c d] format %s $x - # After this, obj in $x should be a dict with a non-NULL bytes field + # After this, obj in $x should be a dict + # We are testing to make sure it has not been shimmered to a + # different intrep when that is not necessary. + # Whether or not there is a string rep - we should not care! tcl::unsupported::representation $x -} -match glob -result {value is a dict with *, string representation "*"} +} -match glob -result {value is a dict *} # cleanup catch {unset a} diff --git a/tests/get.test b/tests/get.test index d51ec6d..7aa06c1 100644 --- a/tests/get.test +++ b/tests/get.test @@ -19,9 +19,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] +testConstraint testdoubleobj [llength [info commands testdoubleobj]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] - + test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} } {66} @@ -95,7 +96,24 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } set result } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} - +# Bug 7114ac6141 +test get-3.3 {tcl_GetInt with iffy numbers} testgetint { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { + catch {testgetint 44 $x} x + set x + } +} {44 44 44 44 54 52 52 46} +test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} { + catch {testdoubleobj set 1 $x} x + set x + } +} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0} + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/history.test b/tests/history.test index 1a255a4..9ff41f2 100644 --- a/tests/history.test +++ b/tests/history.test @@ -11,8 +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 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } @@ -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} @@ -244,7 +245,65 @@ test history-9.2 {miscellaneous} history { catch {history gorp} msg set msg } {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo} + +# History retains references; Bug 1ae12987cb +test history-10.1 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr rand()] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + history clear + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} +test history-10.2 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr rand()] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + rename history {} + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/http.test b/tests/http.test index 41820cb..12ad475 100644 --- a/tests/http.test +++ b/tests/http.test @@ -133,6 +133,7 @@ set tail /a/b/c set url //[info hostname]:$port/a/b/c set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c set binurl //[info hostname]:$port/binary +set xmlurl //[info hostname]:$port/xml set posturl //[info hostname]:$port/post set badposturl //[info hostname]:$port/droppost set authorityurl //[info hostname]:$port @@ -431,6 +432,13 @@ Accept text/plain,application/tcl-test-value Accept-Encoding .* Content-Type application/x-www-form-urlencoded Content-Length 5} +# Bug 838e99a76d +test http-3.33 {http::geturl application/xml is text} -body { + set token [http::geturl "$xmlurl"] + scan [http::data $token] "<%\[^>]>%c<%\[^>]>" +} -cleanup { + catch { http::cleanup $token } +} -result {test 4660 /test} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] diff --git a/tests/httpd b/tests/httpd index c934fac..40e10df 100644 --- a/tests/httpd +++ b/tests/httpd @@ -171,6 +171,10 @@ proc httpdRespond { sock } { set html "$bindata[info hostname]:$port$data(url)" set type application/octet-stream } + *xml* { + set html [encoding convertto utf-8 "<test>\u1234</test>"] + set type "application/xml;charset=UTF-8" + } *post* { set html "Got [string length $data(query)] bytes" set type text/plain diff --git a/tests/indexObj.test b/tests/indexObj.test index 646cb02..126d062 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -109,7 +109,7 @@ test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj { } "wrong # args: should be \"mycmd foo\"" # Contrast this with test proc-3.6; they have to be like this because # of [Bug 1066837] so Itcl won't break. -test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj { +test indexObj-5.7 {Tcl_WrongNumArgs} {testindexobj obsolete} { testwrongnumargs 2 "fee fi" "fo fum" foo bar } "wrong # args: should be \"fo fum foo fee fi\"" diff --git a/tests/info.test b/tests/info.test index 60b9e66..a6a5919 100644 --- a/tests/info.test +++ b/tests/info.test @@ -2398,6 +2398,23 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body { # ------------------------------------------------------------------------- unset -nocomplain res +test info-39.0 {Bug 4b61afd660} -setup { + proc probe {} { + return [dict get [info frame -1] line] + } + set body { + set cmd probe + $cmd + } + proc demo {} $body +} -body { + demo +} -cleanup { + unset -nocomplain body + rename demo {} + rename probe {} +} -result 3 + # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests 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/main.test b/tests/main.test index 96af066..ab66b38 100644 --- a/tests/main.test +++ b/tests/main.test @@ -16,7 +16,7 @@ namespace eval ::tcl::test::main { # - tests use testing commands introduced in Tcltest 8.4 testConstraint Tcltest [expr { [llength [package provide Tcltest]] - && [package vsatisfies [package provide Tcltest] 8.4]}] + && [package vsatisfies [package provide Tcltest] 8.5-]}] # Procedure to simulate interactive typing of commands, line by line proc type {chan script} { diff --git a/tests/msgcat.test b/tests/msgcat.test index f50ebfb..1c3ce58 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -12,7 +12,7 @@ # 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.5 +package require Tcl 8.5- if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return @@ -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-old.test b/tests/namespace-old.test index 1d8ba31..1d6a805 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -57,6 +57,12 @@ test namespace-old-1.9 {add elements to a namespace} { } } } {} +namespace eval test_ns_simple { + variable test_ns_x 0 + proc test {test_ns_x} { + return "test: $test_ns_x" + } +} test namespace-old-1.10 {commands in a namespace} { namespace eval test_ns_simple { info commands [namespace current]::*} } {::test_ns_simple::test} @@ -74,6 +80,12 @@ test namespace-old-1.13 {add to an existing namespace} { } } } "" +namespace eval test_ns_simple { + variable test_ns_y 123 + proc _backdoor {cmd} { + eval $cmd + } +} test namespace-old-1.14 {commands in a namespace} { lsort [namespace eval test_ns_simple {info commands [namespace current]::*}] } {::test_ns_simple::_backdoor ::test_ns_simple::test} @@ -128,6 +140,8 @@ test namespace-old-1.26 {namespace qualifiers are okay after $'s} { test namespace-old-1.27 {can create commands with null names} { proc test_ns_simple:: {args} {return $args} } {} +# Redeclare; later tests depend on it +proc test_ns_simple:: {args} {return $args} # ----------------------------------------------------------------------- # TEST: using "info" in namespace contexts @@ -212,6 +226,11 @@ test namespace-old-4.3 {command "namespace delete" doesn't support patterns} { } list [catch $cmd msg] $msg } {1 {unknown namespace "ns*" in namespace delete command}} +namespace eval test_ns_delete { + namespace eval ns1 {} + namespace eval ns2 {} + namespace eval another {} +} test namespace-old-4.4 {command "namespace delete" handles multiple args} { set cmd { namespace eval test_ns_delete { @@ -256,6 +275,24 @@ test namespace-old-5.3 {namespace qualifiers work in namespace command} { [namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \ [namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}] } {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2} +set ::test_ns_var_global "var in ::" +proc test_ns_cmd_global {} {return "cmd in ::"} +namespace eval test_ns_hier1 { + variable test_ns_var_hier1 "particular to hier1" + proc test_ns_cmd_hier1 {} {return "particular to hier1"} + variable test_ns_level 1 + proc test_ns_show {} {return "[namespace current]: 1"} + namespace eval test_ns_hier2 { + variable test_ns_var_hier2 "particular to hier2" + proc test_ns_cmd_hier2 {} {return "particular to hier2"} + variable test_ns_level 2 + proc test_ns_show {} {return "[namespace current]: 2"} + namespace eval test_ns_hier3a {} + namespace eval test_ns_hier3b {} + } + namespace eval test_ns_hier2a {} + namespace eval test_ns_hier2b {} +} test namespace-old-5.4 {nested namespaces can access global namespace} { list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ @@ -331,16 +368,12 @@ test namespace-old-5.21 {querying namespace parent for explicit namespace} { # ----------------------------------------------------------------------- # TEST: name resolution and caching # ----------------------------------------------------------------------- +set trigger {namespace eval test_ns_cache2 {namespace current}} +set trigger2 {namespace eval test_ns_cache2::test_ns_cache3 {namespace current}} test namespace-old-6.1 {relative ns names only looked up in current ns} { namespace eval test_ns_cache1 {} namespace eval test_ns_cache2 {} namespace eval test_ns_cache2::test_ns_cache3 {} - set trigger { - namespace eval test_ns_cache2 {namespace current} - } - set trigger2 { - namespace eval test_ns_cache2::test_ns_cache3 {namespace current} - } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} @@ -354,20 +387,19 @@ test namespace-old-6.3 {relative ns names only looked up in current ns} { list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} +namespace eval test_ns_cache1::test_ns_cache2 {} test namespace-old-6.4 {relative ns names only looked up in current ns} { namespace delete test_ns_cache1::test_ns_cache2 list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} +namespace eval test_ns_cache1 { + proc trigger {} {test_ns_cache_cmd} +} test namespace-old-6.5 {define test commands} { proc test_ns_cache_cmd {} { return "global version" } - namespace eval test_ns_cache1 { - proc trigger {} { - test_ns_cache_cmd - } - } test_ns_cache1::trigger } {global version} test namespace-old-6.6 {one-level check for command shadowing} { @@ -376,24 +408,36 @@ test namespace-old-6.6 {one-level check for command shadowing} { } test_ns_cache1::trigger } {cache1 version} -test namespace-old-6.7 {renaming commands changes command epoch} { - namespace eval test_ns_cache1 { - rename test_ns_cache_cmd test_ns_new +proc test_ns_cache_cmd {} { + return "global version" +} +test namespace-old-6.7 {renaming commands changes command epoch} -setup { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" } - test_ns_cache1::trigger -} {global version} -test namespace-old-6.8 {renaming back handles shadowing} { - namespace eval test_ns_cache1 { - rename test_ns_new test_ns_cache_cmd +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_cache_cmd test_ns_new}]\ + [test_ns_cache1::trigger] +} -result {{cache1 version} {} {global version}} +test namespace-old-6.8 {renaming back handles shadowing} -setup { + proc test_ns_cache1::test_ns_new {} { + return "cache1 version" } - test_ns_cache1::trigger -} {cache1 version} -test namespace-old-6.9 {deleting commands changes command epoch} { - namespace eval test_ns_cache1 { - rename test_ns_cache_cmd "" +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_new test_ns_cache_cmd}]\ + [test_ns_cache1::trigger] +} -result {{global version} {} {cache1 version}} +test namespace-old-6.9 {deleting commands changes command epoch} -setup { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" } - test_ns_cache1::trigger -} {global version} +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_cache_cmd ""}] \ + [test_ns_cache1::trigger] +} -result {{cache1 version} {} {global version}} test namespace-old-6.10 {define test namespaces} { namespace eval test_ns_cache2 { proc test_ns_cache_cmd {} { @@ -412,6 +456,12 @@ test namespace-old-6.10 {define test namespaces} { } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{global cache2 version} {global version}} +namespace eval test_ns_cache1 { + proc trigger {} { test_ns_cache2::test_ns_cache_cmd } + namespace eval test_ns_cache2 { + proc trigger {} { test_ns_cache_cmd } + } +} test namespace-old-6.11 {commands affect all parent namespaces} { proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} { return "cache2 version" @@ -423,18 +473,22 @@ test namespace-old-6.12 {define test variables} { set trigger {set test_ns_cache_var} namespace eval test_ns_cache1 $trigger } {global version} + set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } namespace eval test_ns_cache1 $trigger } {cache1 version} +variable ::test_ns_cache_var "global version" test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { - unset test_ns_cache_var + variable test_ns_cache_var "cache1 version" } - namespace eval test_ns_cache1 $trigger -} {global version} + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ + [namespace eval test_ns_cache1 $trigger] +} {{cache1 version} {} {global version}} test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" @@ -443,6 +497,7 @@ test namespace-old-6.15 {define test namespaces} { list [namespace eval test_ns_cache1 $trigger2] \ [namespace eval test_ns_cache1::test_ns_cache2 $trigger] } {{global cache2 version} {global version}} +set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" list [namespace eval test_ns_cache1 $trigger2] \ @@ -467,6 +522,7 @@ test namespace-old-6.19 {querying: namespace which -command} { test namespace-old-6.20 {command "namespace which" may not find commands} { namespace eval test_ns_cache1 {namespace which -command xyzzy} } {} +variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" test namespace-old-6.21 {querying: namespace which -variable} { namespace eval test_ns_cache1::test_ns_cache2 { namespace which -variable test_ns_cache_var @@ -493,6 +549,18 @@ test namespace-old-7.1 {define test namespace} { } } } {} +namespace eval test_ns_uplevel { + variable x 0 + variable y 1 + proc show_vars {num} { + return [uplevel $num {info vars}] + } + proc test_uplevel {num} { + set a 0 + set b 1 + namespace eval ::test_ns_uplevel " return \[show_vars $num\] " + } +} test namespace-old-7.2 {uplevel can access namespace call frame} { list [expr {"x" in [test_ns_uplevel::test_uplevel 1]}] \ [expr {"y" in [test_ns_uplevel::test_uplevel 1]}] @@ -526,6 +594,17 @@ test namespace-old-7.8 {namespaces are included in the call stack} { } } } {} +namespace eval test_ns_upvar { + variable scope "test_ns_upvar" + proc show_val {var num} { + upvar $num $var x + return $x + } + proc test_upvar {num} { + set scope "test_ns_upvar::test_upvar" + namespace eval ::test_ns_upvar " return \[show_val scope $num\] " + } +} test namespace-old-7.9 {upvar can access namespace call frame} { test_ns_upvar::test_upvar 1 } {test_ns_upvar} @@ -581,6 +660,15 @@ test namespace-old-9.3 {define test namespaces for import} { } lsort [info commands test_ns_export::*] } {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6} +namespace eval test_ns_export { + namespace export cmd1 cmd2 cmd3 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + proc cmd5 {args} {return "cmd5: $args"} + proc cmd6 {args} {return "cmd6: $args"} +} test namespace-old-9.4 {check export status} { set x "" namespace eval test_ns_import { @@ -592,6 +680,10 @@ test namespace-old-9.4 {check export status} { } set x } {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3} +namespace eval test_ns_import { + namespace export cmd1 cmd2 + namespace import ::test_ns_export::* +} test namespace-old-9.5 {empty import list in "namespace import" command} { namespace eval test_ns_import_empty { namespace import ::test_ns_export::* @@ -615,6 +707,7 @@ test namespace-old-9.8 {only exported commands are imported} { namespace import test_ns_import::cmd* set x [lsort [info commands cmd*]] } {cmd1 cmd2} +namespace import test_ns_import::cmd* test namespace-old-9.9 {imported commands work just the same as original} { list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6] } {{cmd1: test 1 2 3} {cmd1: test 4 5 6}} @@ -629,10 +722,19 @@ test namespace-old-9.10 {commands can be imported from many namespaces} { namespace import test_ns_import2::* lsort [concat [info commands cmd*] [info commands ncmd*]] } {cmd1 cmd2 ncmd ncmd1 ncmd2} +namespace eval test_ns_import2 { + namespace export ncmd ncmd1 ncmd2 + proc ncmd {args} {return "ncmd: $args"} + proc ncmd1 {args} {return "ncmd1: $args"} + proc ncmd2 {args} {return "ncmd2: $args"} + proc ncmd3 {args} {return "ncmd3: $args"} +} +namespace import test_ns_import2::* test namespace-old-9.11 {imported commands can be removed by deleting them} { rename cmd1 "" lsort [concat [info commands cmd*] [info commands ncmd*]] } {cmd2 ncmd ncmd1 ncmd2} +catch { rename cmd1 "" } test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} { list [catch {namespace forget xyzzy::*} msg] $msg } {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} @@ -653,6 +755,7 @@ test namespace-old-9.15 {existing commands can't be overwritten} { [cmd1 3 5] } {1 {can't import command "cmd1": already exists} 8} test namespace-old-9.16 {use "-force" option to override existing commands} { + proc cmd1 {x y} { return [expr $x+$y] } list [cmd1 3 5] \ [namespace import -force test_ns_import::cmd?] \ [cmd1 3 5] @@ -711,10 +814,18 @@ test namespace-old-10.6 {with many args, each "scope" adds new args} { set sval [namespace eval test_ns_inscope {namespace code {one two}}] namespace code "$sval three" } {::namespace inscope ::test_ns_inscope {one two} three} +namespace eval test_ns_inscope { + proc show {args} { + return "show: $args" + } +} test namespace-old-10.7 {scoped commands work with eval} { set cref [namespace eval test_ns_inscope {namespace code show}] list [eval $cref "a" "b c" "d e f"] } {{show: a b c d e f}} +namespace eval test_ns_inscope { + variable x "x-value" +} test namespace-old-10.8 {scoped commands execute in namespace context} { set cref [namespace eval test_ns_inscope { namespace code {set x "some new value"} diff --git a/tests/namespace.test b/tests/namespace.test index 5c5783b..f6f817b 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -82,12 +82,14 @@ test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} { test namespace-5.1 {Tcl_PopCallFrame, no vars} { namespace eval test_ns_1::blodge {} ;# pushes then pops frame } {} -test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} { +test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} -setup { + namespace eval test_ns_1 {} +} -body { proc test_ns_1::r {} { set a 123 } test_ns_1::r ;# pushes then pop's r's frame -} {123} +} -result {123} test namespace-6.1 {Tcl_CreateNamespace} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -194,7 +196,6 @@ test namespace-7.7 {Bug 1655305} -setup { interp delete slave } -result {} - test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp @@ -303,15 +304,24 @@ test namespace-9.4 {Tcl_Import, simple import} { } test_ns_import::p } {cmd1: 123} -test namespace-9.5 {Tcl_Import, RFE 1230597} { +test namespace-9.5 {Tcl_Import, RFE 1230597} -setup { + namespace eval test_ns_import {} + namespace eval test_ns_export {} +} -body { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg -} {0 {}} -test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { +} -result {0 {}} +test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} -setup { + namespace eval test_ns_import {} + namespace eval ::test_ns_export { + proc cmd1 {args} {return "cmd1: $args"} + namespace export cmd1 + } +} -body { namespace eval test_ns_import { namespace import -force ::test_ns_export::* cmd1 555 } -} {cmd1: 555} +} -result {cmd1: 555} test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_export { @@ -329,7 +339,6 @@ test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { [test_ns_import::cmd1 g h i] \ [test_ns_export::cmd1 j k l] } {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}} - test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { namespace eval one { namespace export cmd @@ -354,7 +363,6 @@ test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { } -cleanup { namespace delete one two three } -match glob -result *::one::cmd - test namespace-9.9 {Tcl_Import: Bug 1017299} -setup { namespace eval one { namespace export cmd @@ -388,7 +396,13 @@ test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} { namespace forget ::test_ns_export::wombat } } {} -test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { +test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} -setup { + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } +} -body { namespace eval test_ns_import { namespace import ::test_ns_export::* proc p {} {return [cmd1 123]} @@ -398,8 +412,7 @@ test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { lappend l [info commands ::test_ns_import::*] lappend l [catch {cmd1 777} msg] $msg } -} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] - +} -result [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -417,7 +430,6 @@ test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin unrelated my } - test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -433,7 +445,6 @@ test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin my } -returnCodes error -match glob -result * - test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -450,7 +461,6 @@ test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin my your } -returnCodes error -match glob -result * - test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -471,7 +481,6 @@ test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin link link2 my } -returnCodes error -match glob -result * - test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -492,7 +501,6 @@ test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin link link2 my } - test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -514,29 +522,47 @@ test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup { namespace delete origin link link2 my } -returnCodes error -match glob -result * -test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} { +test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_export { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} } list [namespace origin set] [namespace origin test_ns_export::cmd1] -} {::set ::test_ns_export::cmd1} -test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} { +} -result {::set ::test_ns_export::cmd1} +test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } +} -body { namespace eval test_ns_import1 { namespace import ::test_ns_export::* namespace export * proc p {} {namespace origin cmd1} } list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1] -} {::test_ns_export::cmd1 ::test_ns_export::cmd1} -test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} { +} -result {::test_ns_export::cmd1 ::test_ns_export::cmd1} +test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } + namespace eval test_ns_import1 { + namespace import ::test_ns_export::* + namespace export * + proc p {} {namespace origin cmd1} + } +} -body { namespace eval test_ns_import2 { namespace import ::test_ns_import1::* proc q {} {return [cmd1 123]} } list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1] -} {{cmd1: 123} ::test_ns_export::cmd1} +} -result {{cmd1: 123} ::test_ns_export::cmd1} test namespace-12.1 {InvokeImportedCmd} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -550,14 +576,23 @@ test namespace-12.1 {InvokeImportedCmd} { list [test_ns_import::cmd1] } {::test_ns_export} -test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { +test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {namespace current} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + } +} -body { namespace eval test_ns_import { set l {} lappend l [info commands ::test_ns_import::*] namespace forget ::test_ns_export::cmd1 lappend l [info commands ::test_ns_import::*] } -} {::test_ns_import::cmd1 {}} +} -result {::test_ns_import::cmd1 {}} test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { # Will panic if still buggy namespace eval src {namespace export foo; proc foo {} {}} @@ -568,7 +603,7 @@ test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { namespace delete src } {} -test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { +test namespace-14.1 {TclGetNamespaceForQualName, absolute names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 namespace eval test_ns_1::test_ns_2 { @@ -577,22 +612,41 @@ test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { namespace eval test_ns_2 { variable v 30 } +} -body { namespace eval test_ns_1 { list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \ [lsort [namespace children :: test_ns_*]] } -} [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]] -test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} { +} -result [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]] +test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } +} -body { namespace eval test_ns_1 { list [catch {set ::test_ns_777::v} msg] $msg \ [catch {namespace children test_ns_777} msg] $msg } -} {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} -test namespace-14.3 {TclGetNamespaceForQualName, relative names} { +} -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} +test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } +} -body { namespace eval test_ns_1 { list $v $test_ns_2::v } -} {10 20} +} -result {10 20} test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} @@ -619,57 +673,72 @@ test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up onl [catch {namespace children test_ns_1} msg] $msg } } {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}} -test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} { +test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup { + namespace eval test_ns_1::test_ns_2::foo {} +} -body { namespace children test_ns_1::: -} {::test_ns_1::test_ns_2} -test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} { +} -result {::test_ns_1::test_ns_2} +test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup { + namespace eval test_ns_1::test_ns_2::foo {} +} -body { namespace children :::test_ns_1:::::test_ns_2::: -} {::test_ns_1::test_ns_2::foo} +} -result {::test_ns_1::test_ns_2::foo} test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for vars} { set l {} lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg namespace eval test_ns_1::test_ns_2 {variable {} 2525} lappend l [set test_ns_1::test_ns_2::] } {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525} -test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} { - catch {unset test_ns_1::test_ns_2::} +test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { + namespace eval test_ns_1::test_ns_2::foo {} + unset -nocomplain test_ns_1::test_ns_2:: set l {} +} -body { lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg set test_ns_1::test_ns_2:: 314159 lappend l [set test_ns_1::test_ns_2::] -} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} -test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} { +} -result {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} +test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} -setup { + namespace eval test_ns_1::test_ns_2::foo {} catch {rename test_ns_1::test_ns_2:: {}} set l {} +} -body { lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] -} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} -test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} { +} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} +test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { variable {} set test_ns_1::(x) y } set test_ns_1::(x) -} y -test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} { +} -result y +test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg -} {1 {can't create namespace "": only global namespace can have empty name}} +} -returnCodes error -body { + namespace eval test_ns_1 { + proc {} {} {} + namespace eval {} {} + {} + } +} -result {can't create namespace "": only global namespace can have empty name} -test namespace-15.1 {Tcl_FindNamespace, absolute name found} { +test namespace-15.1 {Tcl_FindNamespace, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_delete { namespace eval test_ns_delete2 {} proc cmd {args} {namespace current} } list [namespace delete ::test_ns_delete::test_ns_delete2] \ [namespace children ::test_ns_delete] -} {{} {}} -test namespace-15.2 {Tcl_FindNamespace, absolute name not found} { - list [catch {namespace delete ::test_ns_delete::test_ns_delete2} msg] $msg -} {1 {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}} +} -result {{} {}} +test namespace-15.2 {Tcl_FindNamespace, absolute name not found} -body { + namespace delete ::test_ns_delete::test_ns_delete2 +} -returnCodes error -result {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command} test namespace-15.3 {Tcl_FindNamespace, relative name found} { namespace eval test_ns_delete { namespace eval test_ns_delete2 {} @@ -685,17 +754,24 @@ test namespace-15.4 {Tcl_FindNamespace, relative name not found} { } } {1 {unknown namespace "test_ns_delete2" in namespace delete command}} -test namespace-16.1 {Tcl_FindCommand, absolute name found} { +test namespace-16.1 {Tcl_FindCommand, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc cmd {args} {return "[namespace current]::cmd: $args"} variable v "::test_ns_1::cmd" eval $v one } -} {::test_ns_1::cmd: one} -test namespace-16.2 {Tcl_FindCommand, absolute name found} { +} -result {::test_ns_1::cmd: one} +test namespace-16.2 {Tcl_FindCommand, absolute name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + variable v "::test_ns_1::cmd" + } +} -body { eval $test_ns_1::v two -} {::test_ns_1::cmd: two} +} -result {::test_ns_1::cmd: two} test namespace-16.3 {Tcl_FindCommand, absolute name not found} { namespace eval test_ns_1 { variable v2 "::test_ns_1::ladidah" @@ -724,11 +800,16 @@ test namespace-16.7 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} { catch {rename unknown {}} catch {rename unknown.old unknown} -test namespace-16.8 {Tcl_FindCommand, relative name found} { +test namespace-16.8 {Tcl_FindCommand, relative name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + } +} -body { namespace eval test_ns_1 { cmd a b c } -} {::test_ns_1::cmd: a b c} +} -result {::test_ns_1::cmd: a b c} test namespace-16.9 {Tcl_FindCommand, relative name found} -body { proc cmd2 {args} {return "[namespace current]::cmd2: $args"} namespace eval test_ns_1 { @@ -750,20 +831,22 @@ test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current } -cleanup { catch {rename cmd2 {}} } -result {::::cmd2: a b c} -test namespace-16.11 {Tcl_FindCommand, relative name not found} { +test namespace-16.11 {Tcl_FindCommand, relative name not found} -body { namespace eval test_ns_1 { - list [catch {cmd3 a b c} msg] $msg + cmd3 a b c } -} {1 {invalid command name "cmd3"}} +} -returnCodes error -result {invalid command name "cmd3"} -catch {unset x} -test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { +unset -nocomplain x +test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { set x 314159 namespace eval test_ns_1 { set ::x } -} {314159} +} -result {314159} +variable ::x 314159 test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} { namespace eval test_ns_1 { variable x 777 @@ -778,46 +861,54 @@ test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} { set ::test_ns_1::test_ns_2::x } } {1111} -test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} { +test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} -body { namespace eval test_ns_1 { namespace eval test_ns_2 { variable x 1111 } - list [catch {set ::test_ns_1::test_ns_2::y} msg] $msg + set ::test_ns_1::test_ns_2::y } -} {1 {can't read "::test_ns_1::test_ns_2::y": no such variable}} -test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} { +} -returnCodes error -result {can't read "::test_ns_1::test_ns_2::y": no such variable} +test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} -setup { + namespace eval ::test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace eval test_ns_3 { variable ::test_ns_1::test_ns_2::x 2222 } } set ::test_ns_1::test_ns_2::x -} {2222} -test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} { +} -result {2222} +test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup { + namespace eval test_ns_1 { + variable x 777 + } +} -body { namespace eval test_ns_1 { set x } -} {777} +} -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 } @@ -828,14 +919,15 @@ 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} catch {unset l} catch {rename foo {}} -test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { +test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc foo {} {return "global foo"} namespace eval test_ns_1 { proc trigger {} { @@ -849,7 +941,7 @@ test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadow proc foo {} {return "foo in test_ns_1"} } lappend l [test_ns_1::trigger] -} {{global foo} {foo in test_ns_1}} +} -result {{global foo} {foo in test_ns_1}} test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { namespace eval test_ns_2 { proc foo {} {return "foo in ::test_ns_2"} @@ -873,22 +965,31 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado catch {unset l} catch {rename foo {}} -test namespace-19.1 {GetNamespaceFromObj, global name found} { +test namespace-19.1 {GetNamespaceFromObj, global name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::test_ns_2 {} namespace children ::test_ns_1 -} {::test_ns_1::test_ns_2} -test namespace-19.2 {GetNamespaceFromObj, relative name found} { +} -result {::test_ns_1::test_ns_2} +test namespace-19.2 {GetNamespaceFromObj, relative name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children test_ns_2 } -} {} -test namespace-19.3 {GetNamespaceFromObj, name not found} -body { +} -result {} +test namespace-19.3 {GetNamespaceFromObj, name not found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace children test_ns_99 } } -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"} -test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { +test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { proc foo {} { return [namespace children test_ns_2] @@ -900,7 +1001,7 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace delete test_ns_1::test_ns_2 namespace eval test_ns_1::test_ns_2::test_ns_3 {} lappend l [test_ns_1::foo] -} {{} ::test_ns_1::test_ns_2::test_ns_3} +} -result {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -913,24 +1014,34 @@ test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { namespace ch :: test_ns_* } {} -test namespace-21.1 {NamespaceChildrenCmd, no args} { +test namespace-21.1 {NamespaceChildrenCmd, no args} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::test_ns_2 {} - expr {[string first ::test_ns_1 [namespace children]] != -1} -} {1} -test namespace-21.2 {NamespaceChildrenCmd, no args} { + expr {"::test_ns_1" in [namespace children]} +} -result {1} +test namespace-21.2 {NamespaceChildrenCmd, no args} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children } -} {::test_ns_1::test_ns_2} -test namespace-21.3 {NamespaceChildrenCmd, ns name given} { +} -result {::test_ns_1::test_ns_2} +test namespace-21.3 {NamespaceChildrenCmd, ns name given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace children ::test_ns_1 -} {::test_ns_1::test_ns_2} -test namespace-21.4 {NamespaceChildrenCmd, ns name given} { +} -result {::test_ns_1::test_ns_2} +test namespace-21.4 {NamespaceChildrenCmd, ns name given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children test_ns_2 } -} {} +} -result {} test namespace-21.5 {NamespaceChildrenCmd, too many args} { namespace eval test_ns_1 { list [catch {namespace children test_ns_2 xxx yyy} msg] $msg @@ -940,10 +1051,13 @@ test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} { namespace eval test_ns_1::test_ns_foo {} namespace children test_ns_1 *f* } {::test_ns_1::test_ns_foo} -test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { +test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1::test_ns_foo {} lsort [namespace children test_ns_1 test*] -} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}] +} -result {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo} test namespace-21.8 {NamespaceChildrenCmd, trivial pattern starting with ::} { namespace eval test_ns_1 {} namespace children [namespace current] [fq test_ns_1] @@ -1038,15 +1152,25 @@ test namespace-25.3 {NamespaceEvalCmd, new namespace} { } test_ns_1::p } {314159} -test namespace-25.4 {NamespaceEvalCmd, existing namespace} { +test namespace-25.4 {NamespaceEvalCmd, existing namespace} -setup { + namespace eval test_ns_1 { + variable v 314159 + proc p {} { + variable v + return $v + } + } +} -body { namespace eval test_ns_1 { proc q {} {return [expr {[p]+1}]} } test_ns_1::q -} {314160} -test namespace-25.5 {NamespaceEvalCmd, multiple args} { +} -result {314160} +test namespace-25.5 {NamespaceEvalCmd, multiple args} -setup { + namespace eval test_ns_1 {variable v 314159} +} -body { namespace eval test_ns_1 "set" "v" -} {314159} +} -result {314159} test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} { list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $::errorInfo } {1 {invalid command name "xxxx"} {invalid command name "xxxx" @@ -1097,21 +1221,50 @@ test namespace-26.4 {NamespaceExportCmd, one pattern} { } list [info commands test_ns_2::*] [test_ns_2::cmd1 hello] } {::test_ns_2::cmd1 {cmd1: hello}} -test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} { +test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} namespace export cmd1 cmd3 } +} -body { namespace eval test_ns_2 { namespace import -force ::test_ns_1::* } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd3 hello] -} [list [lsort {::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd3: hello}] -test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} { +} -result {{::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd3: hello}} +test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + namespace export cmd1 cmd3 + } +} -body { namespace eval test_ns_1 { namespace export } -} {cmd1 cmd3} -test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { +} -result {cmd1 cmd3} +test namespace-26.7 {NamespaceExportCmd, -clear resets export list} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + } +} -body { + namespace eval test_ns_1 { + namespace export cmd1 cmd3 + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + } namespace eval test_ns_1 { namespace export -clear cmd4 } @@ -1119,7 +1272,7 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { namespace import ::test_ns_1::* } 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}] +} -result [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 { @@ -1202,14 +1355,23 @@ test namespace-29.4 {NamespaceInscopeCmd, simple case} { } namespace inscope test_ns_1 cmd } {::test_ns_1::cmd: v=747, args=} -test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} { +test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} -setup { + namespace eval test_ns_1 { + variable v 747 + proc cmd {args} { + variable v + return "[namespace current]::cmd: v=$v, args=$args" + } + } +} -body { list [namespace inscope test_ns_1 cmd x y z] \ [namespace eval test_ns_1 [concat cmd [list x y z]]] -} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} -test namespace-29.6 {NamespaceInscopeCmd, 1400572} { +} -result {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} +test namespace-29.6 {NamespaceInscopeCmd, 1400572} -setup { + namespace eval test_ns_1 {} +} -body { namespace inscope test_ns_1 {info level 0} -} {namespace inscope test_ns_1 {info level 0}} - +} -result {namespace inscope test_ns_1 {info level 0}} test namespace-30.1 {NamespaceOriginCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1330,7 +1492,8 @@ test namespace-34.3 {NamespaceWhichCmd, single arg is always command name} { test namespace-34.4 {NamespaceWhichCmd, bad args} { list [catch {namespace which a b} msg] $msg } {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} -test namespace-34.5 {NamespaceWhichCmd, command lookup} { +test namespace-34.5 {NamespaceWhichCmd, command lookup} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { namespace export cmd* variable v1 111 @@ -1343,6 +1506,7 @@ test namespace-34.5 {NamespaceWhichCmd, command lookup} { variable v2 222 proc p {} {} } +} -body { namespace eval test_ns_3 { namespace import ::test_ns_2::* variable v3 333 @@ -1352,26 +1516,59 @@ test namespace-34.5 {NamespaceWhichCmd, command lookup} { [namespace which -command ::test_ns_2::cmd2] \ [catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg } -} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} -test namespace-34.6 {NamespaceWhichCmd, -command is default} { +} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} +test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + proc p {} {} + } + namespace eval test_ns_3 { + namespace import ::test_ns_2::* + } +} -body { namespace eval test_ns_3 { list [namespace which foreach] \ [namespace which p] \ [namespace which cmd1] \ [namespace which ::test_ns_2::cmd2] } -} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} -test namespace-34.7 {NamespaceWhichCmd, variable lookup} { +} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} +test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + variable v2 222 + proc p {} {} + } + namespace eval test_ns_3 { + variable v3 333 + namespace import ::test_ns_2::* + } +} -body { namespace eval test_ns_3 { list [namespace which -variable env] \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} -test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { +test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc p {} { namespace delete [namespace current] @@ -1379,7 +1576,7 @@ test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { } } test_ns_1::p -} {::test_ns_1} +} -result {::test_ns_1} test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { namespace eval test_ns_1 { proc q {} { @@ -2107,6 +2304,68 @@ test namespace-50.4 {chained ensembles affect error messages} -body { rename a {} rename c {} } +test namespace-50.5 {[4402cfa58c]} -setup { + proc bar {ev} {} + proc bingo {xx} {} + namespace ensemble create -command launch -map {foo bar event bingo} + set result {} +} -body { + catch {launch foo} m; lappend result $m + catch {launch ev} m; lappend result $m + catch {launch foo} m; lappend result $m +} -cleanup { + rename launch {} + rename bingo {} + rename bar {} +} -result {{wrong # args: should be "launch foo ev"} {wrong # args: should be "launch event xx"} {wrong # args: should be "launch foo ev"}} +test namespace-50.6 {[4402cfa58c]} -setup { + proc target {x y} {} + namespace ensemble create -command e2 -map {s2 target} + namespace ensemble create -command e1 -map {s1 e2} + set result {} +} -body { + set s s + catch {e1 s1 s2 a} m; lappend result $m + catch {e1 $s s2 a} m; lappend result $m + catch {e1 s1 $s a} m; lappend result $m + catch {e1 $s $s a} m; lappend result $m +} -cleanup { + rename e1 {} + rename e2 {} + rename target {} +} -result {{wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"}} +test namespace-50.7 {[4402cfa58c]} -setup { + proc target {x y} {} + namespace ensemble create -command e2 -map {s2 target} + namespace ensemble create -command e1 -map {s1 e2} -parameters foo + set result {} +} -body { + set s s + catch {e1 s2 s1 a} m; lappend result $m + catch {e1 $s s1 a} m; lappend result $m + catch {e1 s2 $s a} m; lappend result $m + catch {e1 $s $s a} m; lappend result $m +} -cleanup { + rename e1 {} + rename e2 {} + rename target {} +} -result {{wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"}} +test namespace-50.8 {[f961d7d1dd]} -setup { + proc target {} {} + namespace ensemble create -command e -map {s target} -parameters {{a b}} +} -body { + e +} -returnCodes error -result {wrong # args: should be "e {a b} subcommand ?arg ...?"} -cleanup { + 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 { @@ -2928,6 +3187,22 @@ test namespace-53.10 {ensembles: nested rewrite} -setup { 0 {1 v}\ 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} +test namespace-53.11 {ensembles: nested rewrite} -setup { + namespace eval ns { + namespace export x + namespace eval x { + proc z2 {a1 a2} {list 2 $a1 $a2} + namespace export z* + namespace ensemble create -parameter p + } + namespace ensemble create + } +} -body { + list [catch {ns x 1 z2} msg] $msg +} -cleanup { + namespace delete ns + unset -nocomplain msg +} -result {1 {wrong # args: should be "ns x 1 z2 a2"}} test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ -setup { 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/oo.test b/tests/oo.test index 9491f78..ccb05c1 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2017,6 +2017,12 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup { test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\"" +test oo-16.1.1 {OO: object introspection} -body { + catch {info object} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info object subcommand ?arg ...?\" + while executing +\"info object\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -2156,6 +2162,12 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup { test oo-17.1 {OO: class introspection} -body { info class } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\"" +test oo-17.1.1 {OO: class introspection} -body { + catch {info class} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info class subcommand ?arg ...?\" + while executing +\"info class\"" test oo-17.2 {OO: class introspection} -body { info class superclass NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -3412,6 +3424,38 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -cleanup { foo destroy } -result {v t} +test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { + oo::class create Super + oo::class create Master { + superclass Super + variable member1 member2 + constructor {} { + set member1 master1 + set member2 master2 + } + method getChild {} { + Child new [self] + } + } + oo::class create Child { + superclass Super + variable member1 result + constructor {m} { + set [namespace current]::member1 child1 + set ns [info object namespace $m] + namespace upvar $ns member1 l1 member2 l2 + upvar 1 member1 l3 member2 l4 + [format namespace] upvar $ns member1 l5 member2 l6 + [format upvar] 1 member1 l7 member2 l8 + set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8] + } + method result {} {return $result} + } +} -body { + [[Master new] getChild] result +} -cleanup { + Super destroy +} -result {master1 master2 master1 master2 master1 master2 master1 master2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... diff --git a/tests/parseOld.test b/tests/parseOld.test index a6e07a2..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 e73ea50..9bb4c08 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -135,6 +135,9 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s z } } + namespace eval :: { + variable r2 "" + } } -constraints testinterpresolver -body { set r0 [namespace eval ::ns2 {x}] set r1 [namespace eval ::ns2 {z}] @@ -184,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 @@ -193,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..e43ce12 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5 +package require Tcl 8.5- if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -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/scan.test b/tests/scan.test index b57b641..7540c9c 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -535,6 +535,12 @@ test scan-5.13 {integer scanning and overflow} { test scan-5.14 {integer scanning} { scan 0xff %u } 0 +test scan-5.15 {Bug be003d570f} { + scan 0x40 %o +} 0 +test scan-5.16 {Bug be003d570f} { + scan 0x40 %b +} 0 test scan-6.1 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} 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/string.test b/tests/string.test index 418bc61..11cbcff 100644 --- a/tests/string.test +++ b/tests/string.test @@ -756,13 +756,13 @@ catch {rename largest_int {}} test string-7.1 {string last, too few args} { list [catch {string last a} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} test string-7.2 {string last, bad args} { list [catch {string last a b c} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} test string-7.3 {string last, too many args} { list [catch {string last a b c d} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} test string-7.4 {string last} { string la xxx xxxx123xx345x678 } 1 @@ -901,6 +901,10 @@ test string-10.20 {string map, dictionaries don't alter map ordering} { set map {aa X a Y} list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] } {XY XY 2 XY} +test string-10.20.1 {string map, dictionaries don't alter map ordering} { + set map {a X b Y a Z} + list [string map [dict create a X b Y a Z] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] +} {ZZZ XXX 2 XXX} test string-10.21 {string map, ABR checks} { string map {longstring foob} long } long diff --git a/tests/stringComp.test b/tests/stringComp.test index 140a270..2aeb08e 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -738,6 +738,9 @@ test stringComp-14.4 {Bug 1af8de570511} { string replace $val[unset val] 1 1 $y }} 4 x } 0x00 +test stringComp-14.5 {} { + string length [string replace [string repeat a\u00fe 2] 3 end {}] +} 3 ## string tolower ## not yet bc 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/tm.test b/tests/tm.test index a4dafe0..567d351 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -6,7 +6,7 @@ # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. -package require Tcl 8.5 +package require Tcl 8.5- if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* 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 968469d..ae8742b 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -138,6 +138,25 @@ test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body { } -cleanup { catch {$s close} } -result "" +# Also causes Tk Bug 10f2e7872b +test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup { + expr srand(12345) + set randdata {} + for {set i 0} {$i<6001} {incr i} { + append randdata [binary format c [expr {int(256*rand())}]] + } +} -body { + set strm [zlib stream compress] + for {set i 1} {$i<3000} {incr i} { + $strm put $randdata + } + $strm put -finalize $randdata + set data [$strm get] + list [string length $data] [string length [zlib decompress $data]] +} -cleanup { + catch {$strm close} + unset -nocomplain randdata data +} -result {120185 18003000} test zlib-8.1 {zlib transformation} -constraints zlib -setup { set file [makeFile {} test.gz] @@ -251,9 +270,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 +289,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 +306,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 +328,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 { @@ -401,6 +424,26 @@ test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup { } -cleanup { removeFile $file } -result 57647 +test zlib-8.17 {Bug dd260aaf: fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push inflate $inSide + zlib push deflate $outSide + list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary] +} -cleanup { + catch {close $inSide} + catch {close $outSide} +} -result {{} {}} +test zlib-8.18 {Bug dd260aaf: fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push inflate $inSide -dictionary "one two" + zlib push deflate $outSide -dictionary "one two" + list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary] +} -cleanup { + catch {close $inSide} + catch {close $outSide} +} -result {{one two} {one two}} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] @@ -893,6 +936,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 |