summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2013-08-14 18:44:51 (GMT)
committerdgp <dgp@users.sourceforge.net>2013-08-14 18:44:51 (GMT)
commit1f563ae9a011345574fb277fe6e8eb7f58916981 (patch)
tree91e5021d194cf249b14156bcd8d1560dce949c2c /tests
parent6f7f64c938f98f268b7e606cf668c40ca66e98c9 (diff)
parent2b3657769b1d0b9ae6e10113b1d3c038b4967899 (diff)
downloadtcl-1f563ae9a011345574fb277fe6e8eb7f58916981.zip
tcl-1f563ae9a011345574fb277fe6e8eb7f58916981.tar.gz
tcl-1f563ae9a011345574fb277fe6e8eb7f58916981.tar.bz2
merge trunkbug_3610404
Diffstat (limited to 'tests')
-rw-r--r--tests/assemble.test3
-rw-r--r--tests/cmdIL.test9
-rw-r--r--tests/compile.test6
-rw-r--r--tests/dict.test18
-rw-r--r--tests/env.test4
-rw-r--r--tests/error.test152
-rw-r--r--tests/for.test134
-rw-r--r--tests/httpd2
-rw-r--r--tests/info.test434
-rw-r--r--tests/misc.test7
-rw-r--r--tests/oo.test36
-rw-r--r--tests/parse.test27
-rw-r--r--tests/reg.test3
-rw-r--r--tests/regexp.test4
-rw-r--r--tests/rename.test7
-rw-r--r--tests/set-old.test5
-rw-r--r--tests/subst.test4
-rw-r--r--tests/unixForkEvent.test45
-rw-r--r--tests/utf.test4
19 files changed, 876 insertions, 28 deletions
diff --git a/tests/assemble.test b/tests/assemble.test
index 7d4e5d1..b0487e6 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} {
-match glob
-result {1 {extra characters after close-brace} {extra characters after close-brace
while executing
-"{}extra
- "
+"{}e"
("assemble" body, line 2)*}}
}
test assemble-4.2 {null command} {
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index 721773f..23a5f96 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -417,6 +417,15 @@ test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} {
test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} {
lsort -ascii -nocase {d E c B a D35 d300 100 20}
} {100 20 a B c d d300 D35 E}
+test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} {
+ scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c
+} {257 32 256}
+test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} {
+ scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c
+} {97 32 97 0 97}
+test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} {
+ scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c
+} {97 32 97 0 97}
test cmdIL-5.1 {lsort with list style index} {
lsort -ascii -decreasing -index {0 1} {
diff --git a/tests/compile.test b/tests/compile.test
index 4d91940..51db0a2 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -707,6 +707,12 @@ test compile-18.19 {disassembler - basics} -setup {
} -cleanup {
foo destroy
} -match glob -result *
+
+test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
+ # This will panic in a --enable-symbols=compile build, unless bug is fixed.
+ apply {{} {list [if 1]}}
+} -returnCodes error -match glob -result *
+
# TODO sometime - check that bytecode from tbcload is *not* disassembled.
# cleanup
diff --git a/tests/dict.test b/tests/dict.test
index 72a336c..02c9050 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -668,6 +668,24 @@ test dict-14.20 {dict for stack space compilation: bug 1903325} {
concat "c=$y,$args"
}} {} 1 2 3
} {c=1,2 3}
+test dict-14.21 {compiled dict for and break} {
+ apply {{} {
+ dict for {a b} {c d e f} {
+ lappend result $a,$b
+ break
+ }
+ return $result
+ }}
+} c,d
+test dict-14.22 {dict for and exception range depths: Bug 3614382} {
+ apply {{} {
+ dict for {a b} {c d} {
+ dict for {e f} {g h} {
+ return 5
+ }
+ }
+ }}
+} 5
# There's probably a lot more tests to add here. Really ought to use a
# coverage tool for this job...
diff --git a/tests/env.test b/tests/env.test
index e75d517..fa76433 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -89,7 +89,7 @@ set printenvScript [makeFile {
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
- CommonProgramFiles ProgramFiles
+ CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
} {
lrem names $name
}
@@ -121,7 +121,7 @@ foreach name [array names env] {
SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
SECURITYSESSIONID LANG WINDIR TERM
- CommonProgramFiles ProgramFiles
+ CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432
}} {
unset env($name)
}
diff --git a/tests/error.test b/tests/error.test
index 97bcc0a..06f8eca 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
testConstraint memory [llength [info commands memory]]
+customMatch pairwise {apply {{a b} {
+ string equal [lindex $b 0] [lindex $b 1]
+}}}
namespace eval ::tcl::test::error {
if {[testConstraint memory]} {
proc getbytes {} {
@@ -314,6 +317,12 @@ test error-8.8 {throw syntax checks} -returnCodes error -body {
test error-8.9 {throw syntax checks} -returnCodes error -body {
throw {} foo
} -result {type must be non-empty list}
+test error-8.10 {Bug 33b7abb8a2: throw stack usage} -returnCodes error -body {
+ apply {code {throw $code foo}} {}
+} -result {type must be non-empty list}
+test error-8.11 {Bug 7174354ecb: throw error message} -returnCodes error -body {
+ throw {not {}a list} x[]y
+} -result {list element in braces followed by "a" instead of space}
# simple try tests: body completes with code ok
@@ -601,21 +610,21 @@ test error-16.7 {try with variable assignment and propagation #2} {
}
list $em [dict get $opts -errorcode]
} {bar FOO}
-test error-16.8 {exception chaining (try=ok, handler=error)} {
+test error-16.8 {exception chaining (try=ok, handler=error)} -body {
#FIXME is the intent of this test correct?
catch {
try { list a b c } on ok {em opts} { throw BAR baz }
} tryem tryopts
- string equal $opts [dict get $tryopts -during]
-} {1}
-test error-16.9 {exception chaining (try=error, handler=error)} {
+ list $opts [dict get $tryopts -during]
+} -match pairwise -result equal
+test error-16.9 {exception chaining (try=error, handler=error)} -body {
# The exception off the handler should chain to the exception off the
# try-body (using the -during option)
catch {
try { throw FOO bar } trap {} {em opts} { throw BAR baz }
} tryem tryopts
- string equal $opts [dict get $tryopts -during]
-} {1}
+ list $opts [dict get $tryopts -during]
+} -match pairwise -result equal
test error-16.10 {no exception chaining when handler is successful} {
catch {
try { throw FOO bar } trap {} {em opts} { list d e f }
@@ -628,6 +637,131 @@ test error-16.11 {no exception chaining when handler is a non-error exception} {
} tryem tryopts
dict exists $tryopts -during
} {0}
+test error-16.12 {compiled try with successfully executed handler} {
+ apply {{} {
+ try { throw FOO bar } trap FOO {} { list a b c }
+ }}
+} {a b c}
+test error-16.13 {compiled try with exception (error) in handler} -body {
+ apply {{} {
+ try { throw FOO bar } trap FOO {} { throw BAR foo }
+ }}
+} -returnCodes error -result {foo}
+test error-16.14 {compiled try with exception (return) in handler} -body {
+ apply {{} {
+ list [catch {
+ try { throw FOO bar } trap FOO {} { return BAR }
+ } msg] $msg
+ }}
+} -result {2 BAR}
+test error-16.15 {compiled try with exception (break) in handler} {
+ apply {{} {
+ for { set i 5 } { $i < 10 } { incr i } {
+ try { throw FOO bar } trap FOO {} { break }
+ }
+ return $i
+ }}
+} {5}
+test error-16.16 {compiled try with exception (continue) in handler} {
+ apply {{} {
+ for { set i 5 } { $i < 10 } { incr i } {
+ try { throw FOO bar } trap FOO {} { continue }
+ incr i 20
+ }
+ return $i
+ }}
+} {10}
+test error-16.17 {compiled try with variable assignment and propagation #1} {
+ # Ensure that the handler variables preserve the exception off the
+ # try-body, and are not modified by the exception off the handler
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap FOO {em} { throw BAR baz }
+ }
+ return $em
+ }}
+} {bar}
+test error-16.18 {compiled try with variable assignment and propagation #2} {
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap FOO {em opts} { throw BAR baz }
+ }
+ list $em [dict get $opts -errorcode]
+ }}
+} {bar FOO}
+test error-16.19 {compiled try exception chaining (try=ok, handler=error)} -body {
+ #FIXME is the intent of this test correct?
+ apply {{} {
+ catch {
+ try { list a b c } on ok {em opts} { throw BAR baz }
+ } tryem tryopts
+ list $opts [dict get $tryopts -during]
+ }}
+} -match pairwise -result equal
+test error-16.20 {compiled try exception chaining (try=error, handler=error)} -body {
+ # The exception off the handler should chain to the exception off the
+ # try-body (using the -during option)
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap {} {em opts} { throw BAR baz }
+ } tryem tryopts
+ list $opts [dict get $tryopts -during]
+ }}
+} -match pairwise -result equal
+test error-16.21 {compiled try exception chaining (try=error, finally=error)} {
+ # The exception off the handler should chain to the exception off the
+ # try-body (using the -during option)
+ apply {{} {
+ catch {
+ try { throw FOO bar } finally { throw BAR baz }
+ } tryem tryopts
+ dict get $tryopts -during -errorcode
+ }}
+} FOO
+test error-16.22 {compiled try: no exception chaining when handler is successful} {
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap {} {em opts} { list d e f }
+ } tryem tryopts
+ dict exists $tryopts -during
+ }}
+} {0}
+test error-16.23 {compiled try: no exception chaining when handler is a non-error exception} {
+ apply {{} {
+ catch {
+ try { throw FOO bar } trap {} {em opts} { break }
+ } tryem tryopts
+ dict exists $tryopts -during
+ }}
+} {0}
+test error-16.24 {compiled try exception chaining (try=ok, handler=error, finally=error)} -body {
+ apply {{} {
+ catch {
+ try {
+ list a b c
+ } on ok {em opts} {
+ throw BAR baz
+ } finally {
+ throw DING dong
+ }
+ } tryem tryopts
+ list $opts [dict get $tryopts -during -during]
+ }}
+} -match pairwise -result equal
+test error-16.25 {compiled try exception chaining (all errors)} -body {
+ apply {{} {
+ catch {
+ try {
+ throw FOO bar
+ } on error {em opts} {
+ throw BAR baz
+ } finally {
+ throw DING dong
+ }
+ } tryem tryopts
+ list $opts [dict get $tryopts -during -during]
+ }}
+} -match pairwise -result equal
# try tests - finally
@@ -709,15 +843,15 @@ test error-18.5 {exception in finally doesn't affect variable assignment} {
}
list $em [dict get $opts -errorcode]
} {bar FOO}
-test error-18.6 {exception chaining in finally (try=ok)} {
+test error-18.6 {exception chaining in finally (try=ok)} -body {
catch {
list a b c
} em expopts
catch {
try { list a b c } finally { throw BAR foo }
} em opts
- string equal $expopts [dict get $opts -during]
-} {1}
+ list $expopts [dict get $opts -during]
+} -match pairwise -result equal
test error-18.7 {exception chaining in finally (try=error)} {
catch {
try { throw FOO bar } finally { throw BAR baz }
diff --git a/tests/for.test b/tests/for.test
index ff4dc0e..8936682 100644
--- a/tests/for.test
+++ b/tests/for.test
@@ -14,6 +14,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc meminfo {} {lindex [split [memory info] "\n"] 3 3}
+}
+
# Basic "for" operation.
test for-1.1 {TclCompileForCmd: missing initial command} {
@@ -345,7 +351,6 @@ proc formatMail {} {
64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \
65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \
}
-
set result ""
set NL "
"
@@ -365,7 +370,6 @@ proc formatMail {} {
} else {
set break 1
}
-
set xmailer 0
set inheaders 1
set last [array size lines]
@@ -386,9 +390,7 @@ proc formatMail {} {
set limit 55
} else {
set limit 55
-
# Decide whether or not to break the body line
-
if {$plen > 0} {
if {[string first {> } $line] == 0} {
# This is quoted text from previous message, don't reformat
@@ -431,7 +433,7 @@ proc formatMail {} {
set climit [expr $limit-1]
set cutoff 50
set continuation 0
-
+
while {[string length $line] > $limit} {
for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} {
set char [string index $line $c]
@@ -824,7 +826,127 @@ test for-6.18 {Tcl_ForObjCmd: for command result} {
1 {invoked "continue" outside of a loop} \
]
-
+test for-7.1 {Bug 3614226: ensure that break cleans up the stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [break] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.2 {Bug 3614226: ensure that continue cleans up the stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {$x < 5} {incr x} {
+ list a b c [continue] d e f
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[break] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} memory {
+ apply {{} {
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts {*}[puts a b c {*}[continue] d e f]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.5 {Bug 3614226: ensure that break cleans up the combination of main and expansion stack} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.6 {Bug 3614226: ensure that continue cleans up the combination of main and expansion stack} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]]
+ }
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.7 {Bug 3614226: ensure that break only cleans up the right amount} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount} memory {
+ apply {{} {
+ set l [lrepeat 50 p q r]
+ # Can't use [memtest]; must be careful when we change stack frames
+ set end [meminfo]
+ for {set i 0} {$i < 5} {incr i} {
+ unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} {
+ puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]]
+ }]
+ set tmp $end
+ set end [meminfo]
+ }
+ expr {$end - $tmp}
+ }}
+} 0
+
# cleanup
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/httpd b/tests/httpd
index f810797..232e80a 100644
--- a/tests/httpd
+++ b/tests/httpd
@@ -40,7 +40,7 @@ proc httpdAccept {newsock ipaddr port} {
fconfigure $newsock -blocking 0 -translation {auto crlf}
httpd_log $newsock Connect $ipaddr $port
set data(ipaddr) $ipaddr
- fileevent $newsock readable [list httpdRead $newsock]
+ after 50 [list fileevent $newsock readable [list httpdRead $newsock]]
}
# read data from a client request
diff --git a/tests/info.test b/tests/info.test
index ebc853a..3057dd2 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -1962,6 +1962,440 @@ test info-9.13 {info level option, value in global context} -body {
} -returnCodes error -result {bad level "2"}
# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ catch {*}{
+ {info frame 0}
+ res
+ }
+ return $res
+}
+test info-33.4 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ dict for {a b} {c d} {*}{
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.5 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ set d {a b}
+ dict update d x y {*}{
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.6 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ set d {}
+ dict with d {*}{
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.7 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ for {*}{
+ {set res [info frame 0]}
+ {1} {} {break}
+ }
+ return $res
+}
+test info-33.8 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ for {*}{
+ {} {1} {}
+ {set res [info frame 0]; break}
+ }
+ return $res
+}
+test info-33.9 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ for {*}{
+ {} {1}
+ {return [info frame 0]}
+ {}
+ }
+}
+test info-33.10 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ for {*}{
+ {}
+ {[return [info frame 0]]}
+ {} {}
+ }
+}
+test info-33.11 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ foreach {*}{
+ x
+ } [return [info frame 0]] {}
+}
+test info-33.12 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ foreach {*}{
+ x y
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.13 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ if {*}{
+ {[return [info frame 0]]}
+ {}
+ }
+}
+test info-33.14 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ if 0 {*}{
+ {} else
+ {return [info frame 0]}
+ }
+}
+test info-33.15 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ incr {*}{
+ x
+ } [return [info frame 0]]
+}
+test info-33.16 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ info level {*}{
+ } [return [info frame 0]]
+}
+test info-33.17 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ string match {*}{
+ } [return [info frame 0]] {}
+}
+test info-33.18 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ string match {*}{
+ {}
+ } [return [info frame 0]]
+}
+test info-33.19 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ string length {*}{
+ } [return [info frame 0]]
+}
+test info-33.20 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ while {*}{
+ {[return [info frame 0]]}
+ } {}
+}
+test info-33.21 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ switch -- {*}{
+ } [return [info frame 0]] {*}{
+ } x y
+}
+test info-33.22 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {*}{
+ {set res [info frame 0]}
+ }
+ return $res
+}
+test info-33.23 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {*}{
+ {set res [info frame 0]}
+ } finally {}
+ return $res
+}
+test info-33.24 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {*}{
+ {set res [info frame 0]}
+ } on ok {} {}
+ return $res
+}
+test info-33.25 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {*}{
+ {set res [info frame 0]}
+ } on ok {} {} finally {}
+ return $res
+}
+test info-33.26 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ while 1 {*}{
+ {return [info frame 0]}
+ }
+}
+test info-33.27 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {} finally {*}{
+ {return [info frame 0]}
+ }
+}
+test info-33.28 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {} on ok {} {} finally {*}{
+ {return [info frame 0]}
+ }
+}
+test info-33.29 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {} on ok {} {*}{
+ {return [info frame 0]}
+ }
+}
+test info-33.30 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ try {} on ok {} {*}{
+ {return [info frame 0]}
+ } finally {}
+}
+test info-33.31 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ binary format {*}{
+ } [return [info frame 0]]
+}
+test info-33.32 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ set format format
+ binary $format {*}{
+ } [return [info frame 0]]
+}
+test info-33.33 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ append x {*}{
+ } [return [info frame 0]]
+}
+test info-33.34 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
+namespace eval foo {}
+proc foo::bar {} {
+ append {*}{
+ } x([return [info frame 0]]) {*}{
+ } a
+}
+test info-33.35 {{*}, literal, simple, bytecompiled} -body {
+ reduce [foo::bar]
+} -cleanup {
+ namespace delete foo
+} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
diff --git a/tests/misc.test b/tests/misc.test
index 6ddc718..d4ece74 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} {
missing close-brace for variable name
missing close-brace for variable name
while executing
-"set tst $a([winfo name $\{zz)
- # this is a bogus comment
- # this is a bogus comment
- # this is a bogus comment
- # this is a bogus comment
- # this is a ..."
+"set tst $a([winfo name $\{"
(procedure "tstProc" line 4)
invoked from within
"tstProc"}]
diff --git a/tests/oo.test b/tests/oo.test
index 84e6236..e0e0791 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -3437,6 +3437,42 @@ test oo-34.8 {TIP 380: slots - presence} {
test oo-34.9 {TIP 380: slots - presence} {
getMethods oo::objdefine::variable
} {{-append -clear -set} {Get Set}}
+
+test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
+ oo::class create fruit {
+ method eat {} {}
+ }
+ set result {}
+} -body {
+ lappend result [fruit create ::apple] [info class superclasses fruit]
+ oo::define fruit superclass
+ lappend result [info class superclasses fruit] \
+ [info object class apple oo::object] \
+ [info class call fruit destroy] \
+ [catch { apple }]
+} -cleanup {
+ unset -nocomplain result
+ fruit destroy
+} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1}
+test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
+ oo::class create fruitMetaclass {
+ superclass oo::class
+ method eat {} {}
+ }
+ set result {}
+} -body {
+ lappend result [fruitMetaclass create ::appleClass] \
+ [appleClass create orange] \
+ [info class superclasses fruitMetaclass]
+ oo::define fruitMetaclass superclass
+ lappend result [info class superclasses fruitMetaclass] \
+ [info object class appleClass oo::class] \
+ [catch { orange }] [info object class orange] \
+ [appleClass create pear]
+} -cleanup {
+ unset -nocomplain result
+ fruitMetaclass destroy
+} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear}
cleanupTests
return
diff --git a/tests/parse.test b/tests/parse.test
index b9cfe80..01443c9 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -27,6 +27,7 @@ testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testevent [llength [info commands testevent]]
+testConstraint memory [llength [info commands memory]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -678,6 +679,26 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar
unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
+test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup {
+ proc getbytes {} {
+ return [lindex [split [memory info] \n] 3 3]
+ }
+} -body {
+ set a() foo
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ set vn {}
+ set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]]
+ if {$res ne {foo bar}} {error "Unexpected result: $res"}
+
+ set tmp $end
+ set end [getbytes]
+ }
+ expr {$end - $tmp}
+} -cleanup {
+ unset -nocomplain a end i vn res tmp
+ rename getbytes {}
+} -result 0
test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -1097,6 +1118,12 @@ test parse-21.0 {Bug 1884496} testevent {
testevent queue a head $::script
vwait done
} {}
+test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent {
+ testevent queue a head {testevent delete a; \
+ set ::done [dict get [info frame 0] line]}
+ vwait done
+ set ::done
+} 2
cleanupTests
}
diff --git a/tests/reg.test b/tests/reg.test
index 559f549..e6ce42c 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -1155,6 +1155,9 @@ test reg-33.15 {Bug 3603557 - an "in the wild" RE} {
(.*) # ConditionalFields
}] 0
} 68
+test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} {
+ lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0
+} 1
# cleanup
::tcltest::cleanupTests
diff --git a/tests/regexp.test b/tests/regexp.test
index 1c30001..1b2bec9 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -876,6 +876,10 @@ test regexp-22.5 {Bug 3610026} -setup {
} -cleanup {
unset -nocomplain e cp
} -returnCodes error -match glob -result {*too many colors*}
+test regexp-22.6 {Bug 6585b21ca8} {
+ expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"}
+} rogr
+
test regexp-23.1 {regexp -all and -line} {
set string ""
diff --git a/tests/rename.test b/tests/rename.test
index 1fa0441..ebf5425 100644
--- a/tests/rename.test
+++ b/tests/rename.test
@@ -140,6 +140,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel {
if {[info exists env(value)]} {
unset env(value)
}
+test rename-4.8 {Bug a16752c252} testdel {
+ set x broken
+ testdel {} foo {set x ok}
+ proc foo args {}
+ rename foo {}
+ return -level 0 $x[unset x]
+} ok
# Save the unknown procedure which is modified by the following test.
diff --git a/tests/set-old.test b/tests/set-old.test
index 52dc0ff..4c25ec5 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -678,6 +678,11 @@ test set-old-8.57 {array command, array get with trivial pattern} {
set a(y) 2
array get a x
} {x 1}
+test set-old-8.58 {array command, array set with LVT and odd length literal} {
+ list [catch {apply {{} {
+ array set a {b c d}
+ }}} msg] $msg
+} {1 {list must have an even number of elements}}
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
diff --git a/tests/subst.test b/tests/subst.test
index 4be4798..7466895 100644
--- a/tests/subst.test
+++ b/tests/subst.test
@@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup {
} -cleanup {
removeFile subst13.tcl
}
+test subst-13.2 {Test for segfault} -body {
+ subst {[}
+} -returnCodes error -result * -match glob
+
# cleanup
::tcltest::cleanupTests
diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test
new file mode 100644
index 0000000..120f362
--- /dev/null
+++ b/tests/unixForkEvent.test
@@ -0,0 +1,45 @@
+# This file contains a collection of tests for the procedures in the file
+# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 1995-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+testConstraint testfork [llength [info commands testfork]]
+
+# Test if the notifier thread is well initialized in a forked interpreter
+# by Tcl_InitNotifier
+test unixforkevent-1.1 {fork and test writeable event} \
+ -constraints {testfork nonPortable} \
+ -body {
+ set myFolder [makeDirectory unixtestfork]
+ set pid [testfork]
+ if {$pid == 0} {
+ # we are the forked process
+ set result initialized
+ set h [open [file join $myFolder test.txt] w]
+ fileevent $h writable\
+ "set result writable;\
+ after cancel [after 1000 {set result timeout}]"
+ vwait result
+ close $h
+ makeFile $result result.txt $myFolder
+ exit
+ }
+ # we are the original process
+ while {![file readable [file join $myFolder result.txt]]} {}
+ viewFile result.txt $myFolder
+ } \
+ -result {writable} \
+ -cleanup {
+ catch { removeFolder $myFolder }
+ }
+
+::tcltest::cleanupTests
+return
diff --git a/tests/utf.test b/tests/utf.test
index c41cfe3..ebab967 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -337,8 +337,8 @@ test utf-21.11 {TclUniCharIsControl} {
string is control \u00ad
} {1}
test utf-21.12 {unicode control char in regc_locale.c} {
- # [Bug 3464428]
- regexp {^[[:cntrl:]]$} \u00ad
+ # [Bug 3464428], [Bug a876646efe]
+ regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad
} {1}
test utf-22.1 {TclUniCharIsWordChar} {