summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorferrieux <ferrieux@users.sourceforge.net>2012-04-24 08:55:55 (GMT)
committerferrieux <ferrieux@users.sourceforge.net>2012-04-24 08:55:55 (GMT)
commited76f23a67ff725a3ef859435e72a1d809d53f8e (patch)
tree06aec4c10110301564a8a95d3a5080f61c8f5513 /tests
parent3ca91bcffca105a9023965df4a51a84ece77d737 (diff)
parentcc79d413c959197709155dc84b0680e37c20400e (diff)
downloadtcl-ed76f23a67ff725a3ef859435e72a1d809d53f8e.zip
tcl-ed76f23a67ff725a3ef859435e72a1d809d53f8e.tar.gz
tcl-ed76f23a67ff725a3ef859435e72a1d809d53f8e.tar.bz2
merge trunk
Diffstat (limited to 'tests')
-rw-r--r--tests/async.test4
-rw-r--r--tests/coroutine.test49
-rw-r--r--tests/oo.test136
-rw-r--r--tests/unixNotfy.test2
-rw-r--r--tests/zlib.test12
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]