summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/clock.test26
-rw-r--r--tests/compile.test42
-rw-r--r--tests/env.test36
-rw-r--r--tests/msgcat.test1
-rw-r--r--tests/nre.test4
-rw-r--r--tests/oo.test64
-rw-r--r--tests/platform.test19
-rw-r--r--tests/safe.test2
-rw-r--r--tests/zlib.test6
9 files changed, 181 insertions, 19 deletions
diff --git a/tests/clock.test b/tests/clock.test
index 2abeab9..615f3a8 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -36931,11 +36931,37 @@ test clock-67.2 {Bug d19a30db57} -body {
# error, not segfault
tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
} -returnCodes error -match glob -result *
+
test clock-67.3 {Bug d19a30db57} -body {
# error, not segfault
tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222
} -returnCodes error -match glob -result *
+test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup {
+ package require msgcat
+ set current [msgcat::mclocale]
+} -body {
+ msgcat::mclocale de_de
+ set res [regexp {^\d{2}\.\d{2}\.\d{4}$} [clock format 1 -locale current -format %x]]
+ msgcat::mclocale en_uk
+ lappend res [regexp {^\d{2}/\d{2}/\d{4}$} [clock format 1 -locale current -format %x]]
+} -cleanup {
+ msgcat::mclocale $current
+} -result {1 1}
+
+test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]} -setup {
+ package require msgcat
+ set current [msgcat::mclocale]
+} -body {
+ msgcat::mclocale de_de
+ set res [clock scan "01.01.1970" -locale current -format %x]
+ msgcat::mclocale en_uk
+ # This will fail without the bug fix, as still de_de is active
+ expr {$res == [clock scan "01/01/1970" -locale current -format %x]}
+} -cleanup {
+ msgcat::mclocale $current
+} -result {1}
+
# cleanup
namespace delete ::testClock
diff --git a/tests/compile.test b/tests/compile.test
index d4a31d4..46e678a 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -765,7 +765,7 @@ test compile-18.24 {disassembler - basics} -returnCodes error -body {
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.25 {disassembler - basics} -body {
dict keys [tcl::unsupported::getbytecode lambda {{} {}}]
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
test compile-18.26 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode proc
} -match glob -result {wrong # args: should be "* proc procName"}
@@ -778,7 +778,43 @@ test compile-18.28 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
+test compile-18.28.1 {disassembler - tricky bit} -setup {
+ eval [list proc chewonthis {} {}]
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename chewonthis {}
+} -result $bytecodekeys
+test compile-18.28.2 {disassembler - tricky bit} -setup {
+ eval {proc chewonthis {} {}}
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
+test compile-18.28.3 {disassembler - tricky bit} -setup {
+ proc Proc {n a b} {
+ proc $n $a $b
+ }
+ Proc chewonthis {} {}
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename Proc {}
+ rename chewonthis {}
} -result $bytecodekeys
+test compile-18.28.4 {disassembler - tricky bit} -setup {
+ proc Proc {n a b} {
+ tailcall proc $n $a $b
+ }
+ Proc chewonthis {} {}
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename Proc {}
+ rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
test compile-18.29 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode script
} -match glob -result {wrong # args: should be "* script script"}
@@ -807,7 +843,7 @@ test compile-18.35 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode method foo bar]
} -cleanup {
foo destroy
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
test compile-18.36 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode objmethod
} -match glob -result {wrong # args: should be "* objmethod objectName methodName"}
@@ -824,7 +860,7 @@ test compile-18.39 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode objmethod foo bar]
} -cleanup {
foo destroy
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
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/env.test b/tests/env.test
index 83d99e0..9f59fbc 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -278,20 +278,20 @@ test env-5.4 {corner cases - unset the env array} -setup {
} -cleanup {
interp delete i
} -result {1 a 1}
-test env-5.5 {corner cases - cannot have null entries on Windows} {win} {
+test env-5.5 {corner cases - cannot have null entries on Windows} -constraints win -body {
set env() a
catch {set env()}
-} {1}
+} -result 1
-test env-6.1 {corner cases - add lots of env variables} {} {
+test env-6.1 {corner cases - add lots of env variables} -body {
set size [array size env]
for {set i 0} {$i < 100} {incr i} {
set env(BOGUS$i) $i
}
expr {[array size env] - $size}
-} 100
+} -result 100
-test env-7.1 {[219226]: whole env array should not be unset by read} {
+test env-7.1 {[219226]: whole env array should not be unset by read} -body {
set n [array size env]
set s [array startsearch env]
while {[array anymore env $s]} {
@@ -300,19 +300,29 @@ test env-7.1 {[219226]: whole env array should not be unset by read} {
}
array donesearch env $s
return $n
-} 0
-test env-7.2 {[219226]: links to env elements should not be removed by read} {
+} -result 0
+
+test env-7.2 {[219226]: links to env elements should not be removed by read} -body {
apply {{} {
set ::env(test7_2) ok
upvar env(test7_2) elem
set ::env(PATH)
- try {
- return $elem
- } finally {
- unset ::env(test7_2)
- }
+ return $elem
+ }}
+} -result ok
+
+test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy trace} -body {
+ apply {{} {
+ catch {unset ::env(test7_3)}
+ proc foo args {
+ set ::env(test7_3) ok
+ }
+ trace add variable ::env(not_yet_existent) write foo
+ info exists ::env(not_yet_existent)
+ set ::env(not_yet_existent) "Now I'm here";
+ return [info exists ::env(test7_3)]
}}
-} ok
+} -result 1
# Restore the environment variables at the end of the test.
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 6b965d1..8647f9c 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -995,6 +995,7 @@ namespace eval ::msgcat::test {
mcloadedlocales clear
} -cleanup {
mcforgetpackage
+ after cancel set [namespace current]::resultvariable timeout
} -body {
mcpackageconfig set loadcmd [namespace code callbackfailproc]
mclocale foo_bar
diff --git a/tests/nre.test b/tests/nre.test
index e512eac..9df5eb1 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -64,6 +64,10 @@ if {[testConstraint testnrelevels]} {
namespace import testnre::*
}
+test nre-0.1 {levels while unwinding} {
+ testnreunwind
+} {0 0 0}
+
test nre-1.1 {self-recursive procs} -setup {
proc a i [makebody {a $i}]
} -body {
diff --git a/tests/oo.test b/tests/oo.test
index c83e015..895f7ed 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -638,6 +638,57 @@ test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup {
} -cleanup {
cls destroy
} -result {in destructor}
+test oo-3.10 {Bug 3d96b7076e: killing the object's class in a method call} -setup {
+ oo::class create Super
+} -body {
+ # Only reliably failed in a memdebug build
+ oo::class create Cls {
+ superclass Super
+ method mthd {} {
+ [self class] destroy
+ return ok
+ }
+ }
+ [Cls new] mthd
+} -cleanup {
+ Super destroy
+} -result ok
+test oo-3.11 {Bug 3d96b7076e: killing the object's class in a method call} -setup {
+ oo::class create Super
+ oo::class create Sub {
+ superclass Super
+ }
+} -body {
+ # Only reliably failed in a memdebug build
+ oo::class create Cls {
+ superclass Super
+ method mthd {} {
+ oo::objdefine [self] class Sub
+ Cls destroy
+ return ok
+ }
+ }
+ [Cls new] mthd
+} -cleanup {
+ Super destroy
+} -result ok
+test oo-3.12 {Bug 3d96b7076e: killing the object's class in a method call} -setup {
+ oo::class create Super
+} -body {
+ # Only reliably failed in a memdebug build
+ oo::class create Cls {
+ superclass Super
+ method mthd {} {
+ [self class] destroy
+ return ok
+ }
+ }
+ set o [Super new]
+ oo::objdefine $o mixin Cls
+ $o mthd
+} -cleanup {
+ Super destroy
+} -result ok
test oo-4.1 {basic test of OO functionality: export} {
set o [oo::object new]
@@ -3620,6 +3671,19 @@ test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
unset -nocomplain result
fruitMetaclass destroy
} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear}
+test oo-35.3 {Bug 593baa032c: superclass list teardown} {
+ # Bug makes this crash, especially with mem-debugging on
+ oo::class create B {}
+ oo::class create D {superclass B}
+ namespace eval [info object namespace D] [list [namespace which B] destroy]
+} {}
+test oo-35.4 {Bug 593baa032c: mixins list teardown} {
+ # Bug makes this crash, especially with mem-debugging on
+ oo::class create B {}
+ oo::class create D {mixin B}
+ namespace eval [info object namespace D] [list [namespace which B] destroy]
+} {}
+
cleanupTests
return
diff --git a/tests/platform.test b/tests/platform.test
index 6596975..c826444 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -1,4 +1,4 @@
-# The file tests the tcl_platform variable
+# The file tests the tcl_platform variable and platform package.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
@@ -23,6 +23,10 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testCPUID [llength [info commands testcpuid]]
+test platform-1.0 {tcl_platform(engine)} {
+ set tcl_platform(engine)
+} {Tcl}
+
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
@@ -30,7 +34,7 @@ test platform-1.1 {TclpSetVariables: tcl_platform} {
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
-} {byteOrder machine os osVersion pathSeparator platform pointerSize user wordSize}
+} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}
# Test assumes twos-complement arithmetic, which is true of virtually
# everything these days. Note that this does *not* use wide(), and
@@ -57,6 +61,17 @@ test platform-3.1 {CPU ID on Windows/UNIX} \
-match regexp \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
+# The platform package makes very few promises, but does promise that the
+# format of string it produces consists of two non-empty words separated by a
+# hyphen.
+package require platform
+test platform-4.1 {format of platform::identify result} -match regexp -body {
+ platform::identify
+} -result {^([^-]+-)+[^-]+$}
+test platform-4.2 {format of platform::generic result} -match regexp -body {
+ platform::generic
+} -result {^([^-]+-)+[^-]+$}
+
# cleanup
cleanupTests
diff --git a/tests/safe.test b/tests/safe.test
index 859f352..94c1755 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -174,7 +174,7 @@ test safe-6.3 {test safe interpreters knowledge of the world} {
}
set r [lsearch -all -inline -not -exact $r "threaded"]
lsort $r
-} {byteOrder pathSeparator platform pointerSize wordSize}
+} {byteOrder engine pathSeparator platform pointerSize wordSize}
# More test should be added to check that hostname, nameofexecutable, aren't
# leaking infos, but they still do...
diff --git a/tests/zlib.test b/tests/zlib.test
index b1d43fb..7a486ba 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -132,6 +132,12 @@ test zlib-7.6 {zlib stream} zlib {
$s close
lappend result $data
} {{} 69f34b6a abcdeEDCBA..}
+test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body {
+ set s [zlib stream deflate]
+ $s put {}
+} -cleanup {
+ catch {$s close}
+} -result ""
test zlib-8.1 {zlib transformation} -constraints zlib -setup {
set file [makeFile {} test.gz]
generated by cgit v0.12 at 2024-07-04 20:12:11 (GMT)