merge trunk

5 files changed, 184 insertions, 19 deletions

diff --git a/tests/async.test b/tests/async.test
index 7834ed5..35dda88 100644
--- a/tests/async.test
+++ b/tests/async.test
@@ -17,9 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 }
 
 testConstraint testasync [llength [info commands testasync]]
-testConstraint threaded [expr {
-    [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded)
-}]
+testConstraint threaded [::tcl::pkgconfig get threaded]
 
 proc async1 {result code} {
     global aresult acode
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 7d5169b..7f40a7b 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -557,12 +557,25 @@ test coroutine-6.3 {coroutine nargs} -body {
 } -cleanup {
     rename a {}
 } -returnCodes error -result {wrong # args: should be "a ?arg?"}
-test coroutine-6.4 {unsupported: multi-argument yield} -body {
+
+test coroutine-7.1 {yieldto} -body {
+    coroutine c apply {{} {
+	yield
+	yieldto return -level 0 -code 1 quux
+	return quuy
+    }}
+    set res [list [catch c msg] $msg]
+    lappend res [catch c msg] $msg
+    lappend res [catch c msg] $msg
+} -cleanup {
+    unset res
+} -result [list 1 quux 0 quuy 1 {invalid command name "c"}]
+test coroutine-7.2 {multi-argument yielding with yieldto} -body {
     proc corobody {} {
 	set a 1
 	while 1 {
 	    set a [yield $a]
-	    set a [::tcl::unsupported::yieldm $a]
+	    set a [yieldto return -level 0 $a]
 	    lappend a [llength $a]
 	}
     }
@@ -573,20 +586,26 @@ test coroutine-6.4 {unsupported: multi-argument yield} -body {
 } -cleanup {
     rename corobody {}
 } -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}}
-
-test coroutine-7.1 {yieldTo} -body {
-    coroutine c apply {{} {
-	yield
-	tcl::unsupported::yieldTo return -level 0 -code 1 quux
-	return quuy
-    }}
-    set res [list [catch c msg] $msg]
-    lappend res [catch c msg] $msg
-    lappend res [catch c msg] $msg
+test coroutine-7.3 {yielding between coroutines} -body {
+    proc juggler {target {value ""}} {
+	if {$value eq ""} {
+	    set value [yield [info coroutine]]
+	}
+	while {[llength $value]} {
+	    lappend ::result $value [info coroutine]
+	    set value [lrange $value 0 end-1]
+	    lassign [yieldto $target $value] value
+	}
+	# Clear nested collection of coroutines
+	catch $target
+    }
+    set result ""
+    coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\
+	{a b c d e}
+    list $result [info command j1] [info command j2] [info command j3]
 } -cleanup {
-    unset res
-} -result [list 1 quux 0 quuy 1 {invalid command name "c"}]
-
+    catch {rename juggler ""}
+} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
 
 # cleanup
 unset lambda
diff --git a/tests/oo.test b/tests/oo.test
index 150bc97..f3c0bda 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -337,6 +337,45 @@ test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup {
 } -cleanup {
     foo destroy
 } -result good
+test oo-2.7 {construction, method calls and ensembles - Bug 3514761} -setup {
+    namespace eval k {}
+} -body {
+    namespace eval k {
+	oo::class create s {
+	    constructor {j} {
+		# nothing
+	    }
+	}
+	namespace export s
+	namespace ensemble create
+    }
+    k s create X
+} -returnCodes error -cleanup {
+    namespace delete k
+} -result {wrong # args: should be "k s create X j"}
+test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup {
+    namespace eval k {}
+} -body {
+    namespace eval k {
+	oo::class create s {
+	    constructor {j} {
+		# nothing
+	    }
+	}
+	oo::class create t {
+	    superclass s
+	    constructor args {
+		k next {*}$args
+	    }
+	}
+	interp alias {} ::k::next {} ::oo::Helpers::next
+	namespace export t next
+	namespace ensemble create
+    }
+    k t create X
+} -returnCodes error -cleanup {
+    namespace delete k
+} -result {wrong # args: should be "k next j"}
 
 test oo-3.1 {basic test of OO functionality: destructor} -setup {
     # This is a bit complex because it needs to run in a sub-interp as we're
@@ -1726,6 +1765,17 @@ test oo-15.8 {OO: intercept object cloning} -setup {
 } -cleanup {
     Foo destroy
 } -result {cloned ::foo ::bar check ::foo ok check ::bar ok}
+test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup {
+    oo::class create Foo
+} -body {
+    oo::define Foo {
+	method <cloned> {a b} {}
+    }
+    interp alias {} Bar {} oo::copy [Foo create foo]
+    Bar bar
+} -returnCodes error -cleanup {
+    Foo destroy
+} -result {wrong # args: should be "::bar <cloned> a b"}
 
 test oo-16.1 {OO: object introspection} -body {
     info object
@@ -2896,6 +2946,92 @@ test oo-27.18 {variables declaration - multiple use} -setup {
     foo create bar
     list [bar boo] [bar boo]
 } -returnCodes error -match glob -result {unknown method "-?": must be *}
+test oo-27.19 {variables declaration and [info vars]: Bug 2712377} -setup {
+    oo::class create Foo
+    set result {}
+} -body {
+    # This is really a test of problems to do with Tcl's introspection when a
+    # variable resolver is present...
+    oo::define Foo {
+	variable foo bar
+	method setvars {f b} {
+	    set foo $f
+	    set bar $b
+	}
+	method dump1 {} {
+	    lappend ::result <1>
+	    foreach v [lsort [info vars *]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result [info locals] [info locals *]
+	}
+	method dump2 {} {
+	    lappend ::result <2>
+	    foreach v [lsort [info vars *]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result | foo=$foo [info locals] [info locals *]
+	}
+    }
+    Foo create stuff
+    stuff setvars what ever
+    stuff dump1
+    stuff dump2
+    return $result
+} -cleanup {
+    Foo destroy
+} -result {<1> bar=ever foo=what v v <2> bar=ever foo=what | foo=what v v}
+test oo-27.20 {variables declaration and [info vars]: Bug 2712377} -setup {
+    oo::class create Foo
+    set result {}
+} -body {
+    # This is really a test of problems to do with Tcl's introspection when a
+    # variable resolver is present...
+    oo::define Foo {
+	variable foo bar
+	method setvars {f b} {
+	    set foo $f
+	    set bar $b
+	}
+	method dump1 {} {
+	    lappend ::result <1>
+	    foreach v [lsort [info vars *o]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result [info locals] [info locals *]
+	}
+	method dump2 {} {
+	    lappend ::result <2>
+	    foreach v [lsort [info vars *o]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result | foo=$foo [info locals] [info locals *]
+	}
+    }
+    Foo create stuff
+    stuff setvars what ever
+    stuff dump1
+    stuff dump2
+    return $result
+} -cleanup {
+    Foo destroy
+} -result {<1> foo=what v v <2> foo=what | foo=what v v}
+test oo-27.21 {variables declaration uniqueifies: Bug 3396896} -setup {
+    oo::class create Foo
+} -body {
+    oo::define Foo variable v v v t t v t
+    info class variable Foo
+} -cleanup {
+    Foo destroy
+} -result {v t}
+test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup {
+    oo::object create foo
+} -body {
+    oo::objdefine foo variable v v v t t v t
+    info object variable foo
+} -cleanup {
+    foo destroy
+} -result {v t}
 
 # A feature that's not supported because the mechanism may change without
 # warning, but is supposed to work...
diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index 067d225..0646a3d 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -20,7 +20,7 @@ testConstraint noTk [expr {0 != [catch {package present Tk}]}]
 testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 # Darwin always uses a threaded notifier
 testConstraint unthreaded [expr {
-    (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded))
+    ![::tcl::pkgconfig get threaded]
     && $tcl_platform(os) ne "Darwin"
 }]
 
diff --git a/tests/zlib.test b/tests/zlib.test
index 236e6b6..3aaca29 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -156,6 +156,18 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
     close $srv
     removeFile $file
 } -result 81920-->81920
+test zlib-8.4 {transformation and flushing: Bug 3517696} -setup {
+    set file [makeFile {} test.z]
+    set fd [open $file w]
+} -constraints zlib -body {
+    zlib push compress $fd
+    puts $fd "qwertyuiop"
+    fconfigure $fd -flush sync
+    puts $fd "qwertyuiop"
+} -cleanup {
+    catch {close $fd}
+    removeFile $file
+} -result {}
 
 test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
     set sfile [makeFile {} testsrc.gz]