summaryrefslogtreecommitdiffstats
path: root/tests/oo.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/oo.test')
-rw-r--r--tests/oo.test1508
1 files changed, 1475 insertions, 33 deletions
diff --git a/tests/oo.test b/tests/oo.test
index 2df1d4d..d63e931 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2,16 +2,14 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 2006-2008 Donal K. Fellows
+# Copyright (c) 2006-2013 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: oo.test,v 1.15 2008/10/10 13:04:09 dkf Exp $
-package require TclOO 0.4 ;# Must match value in configure.in
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
+package require TclOO 1.0.1
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
@@ -31,15 +29,9 @@ if {[testConstraint memory]} {
return [expr {$end - $tmp}]
}
}
-
-proc initInterpreter name {
- $name eval [list package ifneeded TclOO [package provide TclOO] \
- [package ifneeded TclOO [package provide TclOO]]]
-}
-
+
test oo-0.1 {basic test of OO's ability to clean up its initial state} {
interp create t
- initInterpreter t
t eval {
package require TclOO
}
@@ -47,11 +39,11 @@ test oo-0.1 {basic test of OO's ability to clean up its initial state} {
} {}
test oo-0.2 {basic test of OO's ability to clean up its initial state} {
set i [interp create]
- initInterpreter $i
interp eval $i {
package require TclOO
namespace delete ::
}
+ interp delete $i
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
@@ -72,6 +64,44 @@ test oo-0.5 {testing literal leak on interp delete} memory {
interp delete foo
}
} 0
+test oo-0.6 {cleaning the core class pair; way #1} -setup {
+ interp create t
+} -body {
+ t eval {
+ package require TclOO
+ namespace path oo
+ list [catch {class destroy} m] $m [catch {object destroy} m] $m
+ }
+} -cleanup {
+ interp delete t
+} -result {0 {} 1 {invalid command name "object"}}
+test oo-0.7 {cleaning the core class pair; way #2} -setup {
+ interp create t
+} -body {
+ t eval {
+ package require TclOO
+ namespace path oo
+ list [catch {object destroy} m] $m [catch {class destroy} m] $m
+ }
+} -cleanup {
+ interp delete t
+} -result {0 {} 1 {invalid command name "class"}}
+test oo-0.8 {leak in variable management} -setup {
+ oo::class create foo
+} -constraints memory -body {
+ oo::define foo {
+ constructor {} {
+ variable v 0
+ }
+ }
+ leaktest {[foo new] destroy}
+} -cleanup {
+ foo destroy
+} -result 0
+test oo-0.9 {various types of presence of the TclOO package} {
+ list [lsearch -nocase -all -inline [package names] tcloo] \
+ [package present TclOO] [package versions TclOO]
+} [list TclOO $::oo::patchlevel $::oo::patchlevel]
test oo-1.1 {basic test of OO functionality: no classes} {
set result {}
@@ -101,6 +131,13 @@ test oo-1.4 {basic test of OO functionality} -body {
test oo-1.5 {basic test of OO functionality} -body {
oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
+test oo-1.5.1 {basic test of OO functionality} -setup {
+ oo::object create aninstance
+} -returnCodes error -body {
+ aninstance
+} -cleanup {
+ rename aninstance {}
+} -result {wrong # args: should be "aninstance method ?arg ...?"}
test oo-1.6 {basic test of OO functionality} -setup {
oo::object create aninstance
} -body {
@@ -204,12 +241,40 @@ test oo-1.16 {basic test of OO functionality: abbreviating} -setup {
oo::objdefine o forw a b
info object forw o a
} -result b
+test oo-1.17 {basic test of OO functionality: Bug 2481109} -body {
+ namespace eval ::foo {oo::object create lreplace}
+} -cleanup {
+ namespace delete ::foo
+} -result ::foo::lreplace
+# Check for Bug 2519474; problem in tclNamesp.c, but tested here...
+test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
+ proc test-oo-1.18 {} return
+ oo::class create A
+ oo::class create B {superclass A}
+} -body {
+ oo::define B constructor {} {A create test-oo-1.18}
+ B create C
+} -cleanup {
+ rename test-oo-1.18 {}
+ A destroy
+} -result ::C
+test oo-1.19 {basic test of OO functionality: teardown order} -body {
+ oo::object create o
+ namespace delete [info object namespace o]
+ o destroy
+ # Crashes on error
+} -returnCodes error -result {invalid command name "o"}
+test oo-1.20 {basic test of OO functionality: my teardown post rename} -body {
+ oo::object create obj
+ rename [info object namespace obj]::my ::AGlobalName
+ obj destroy
+ info commands ::AGlobalName
+} -result {}
test oo-2.1 {basic test of OO functionality: constructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
# we're modifying the root object class's constructor
interp create subinterp
- initInterpreter subinterp
subinterp eval {
package require TclOO
}
@@ -240,12 +305,82 @@ test oo-2.2 {basic test of OO functionality: constructor} {
testClass destroy
return $result
} {::foo->construct ::foo->bar}
+test oo-2.4 {OO constructor - Bug 2531577} -setup {
+ oo::class create foo
+} -body {
+ oo::define foo constructor {} return
+ [foo new] destroy
+ oo::define foo constructor {} {}
+ llength [info command [foo new]]
+} -cleanup {
+ foo destroy
+} -result 1
+test oo-2.5 {OO constructor - Bug 2531577} -setup {
+ oo::class create foo
+ set result {}
+} -body {
+ oo::define foo constructor {} {error x}
+ lappend result [catch {foo new}]
+ oo::define foo constructor {} {}
+ lappend result [llength [info command [foo new]]]
+} -cleanup {
+ foo destroy
+} -result {1 1}
+test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup {
+ oo::class create foo
+} -body {
+ oo::define foo {
+ constructor {} { tailcall my bar }
+ method bar {} { return bad }
+ }
+ namespace tail [foo create good]
+} -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 modifying the root object class's constructor
+ # This is a bit complex because it needs to run in a sub-interp as we're
+ # modifying the root object class's constructor
interp create subinterp
- initInterpreter subinterp
subinterp eval {
package require TclOO
}
@@ -266,7 +401,6 @@ test oo-3.2 {basic test of OO functionality: destructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
# we're modifying the root object class's constructor
interp create subinterp
- initInterpreter subinterp
subinterp eval {
package require TclOO
}
@@ -281,6 +415,164 @@ test oo-3.2 {basic test of OO functionality: destructor} -setup {
} -cleanup {
interp delete subinterp
} -result {1 ::foo died 2 {}}
+test oo-3.3 {basic test of OO functionality: destructor} -setup {
+ oo::class create foo
+ set result {}
+} -cleanup {
+ foo destroy
+} -body {
+ oo::define foo {
+ constructor {} {lappend ::result made}
+ destructor {lappend ::result died}
+ }
+ namespace delete [info object namespace [foo new]]
+ return $result
+} -result {made died}
+test oo-3.4 {basic test of OO functionality: my exists in destructor} -setup {
+ oo::class create cls
+ set result {}
+} -cleanup {
+ cls destroy
+} -body {
+ oo::define cls {
+ variable state
+ constructor {} {
+ proc localcmdexists {} {}
+ set state ok
+ }
+ forward Report lappend ::result
+ destructor {
+ objmy Report [catch {set state} msg] $msg
+ objmy Report [namespace which -var state]
+ objmy Report [info commands localcmdexists]
+ }
+ }
+ cls create obj
+ rename [info object namespace obj]::my ::objmy
+ obj destroy
+ lappend result [info commands ::objmy]
+} -match glob -result {0 ok *::state localcmdexists {}}
+test oo-3.4a {basic test of OO functionality: my exists in destructor} -setup {
+ oo::class create cls
+ set result {}
+} -cleanup {
+ cls destroy
+} -body {
+ oo::define cls {
+ variable state
+ constructor {} {
+ proc localcmdexists {} {}
+ set state ok
+ }
+ forward Report lappend ::result
+ destructor {
+ objmy Report [catch {set state} msg] $msg
+ objmy Report [namespace which -var state]
+ objmy Report [info commands localcmdexists]
+ }
+ }
+ cls create obj
+ rename [info object namespace obj]::my ::objmy
+ rename obj {}
+ lappend result [info commands ::objmy]
+} -match glob -result {0 ok *::state localcmdexists {}}
+test oo-3.5 {basic test of OO functionality: destructor: evil case for Itcl} -setup {
+ oo::class create cls
+ set result {}
+} -cleanup {
+ cls destroy
+} -body {
+ oo::define cls {
+ variable state
+ constructor {} {
+ proc localcmdexists {} {}
+ set state ok
+ }
+ forward Report lappend ::result
+ destructor {
+ objmy Report [catch {set state} msg] $msg
+ objmy Report [namespace which -var state]
+ objmy Report [info commands localcmdexists]
+ }
+ }
+ cls create obj
+ rename [info object namespace obj]::my ::objmy
+ namespace delete [info object namespace obj]
+ lappend result [info commands ::objmy]
+} -match glob -result {0 ok *::state localcmdexists {}}
+test oo-3.5a {basic test of OO functionality: destructor: evil case for Itcl} -setup {
+ oo::class create cls
+ set result {}
+} -cleanup {
+ cls destroy
+} -body {
+ oo::define cls {
+ variable state result
+ constructor {} {
+ proc localcmdexists {} {}
+ set state ok
+ my eval {upvar 0 ::result result}
+ }
+ method nuke {} {
+ namespace delete [namespace current]
+ return $result
+ }
+ destructor {
+ lappend result [self] $state [info commands localcmdexists]
+ }
+ }
+ cls create obj
+ namespace delete [info object namespace obj]
+ [cls create obj2] nuke
+} -match glob -result {::obj ok localcmdexists ::obj2 ok localcmdexists}
+test oo-3.6 {basic test of OO functionality: errors in destructor} -setup {
+ oo::class create cls
+} -cleanup {
+ cls destroy
+} -body {
+ oo::define cls destructor {error foo}
+ list [catch {[cls create obj] destroy} msg] $msg [info commands obj]
+} -result {1 foo {}}
+test oo-3.7 {basic test of OO functionality: errors in destructor} -setup {
+ oo::class create cls
+ set result {}
+ proc bgerror msg {lappend ::result $msg}
+} -cleanup {
+ cls destroy
+ rename bgerror {}
+} -body {
+ oo::define cls destructor {error foo}
+ list [rename [cls create obj] {}] \
+ [update idletasks] $result [info commands obj]
+} -result {{} {} foo {}}
+test oo-3.8 {basic test of OO functionality: errors in destructor} -setup {
+ oo::class create cls
+ set result {}
+ proc bgerror msg {lappend ::result $msg}
+} -cleanup {
+ cls destroy
+ rename bgerror {}
+} -body {
+ oo::define cls destructor {error foo}
+ list [namespace delete [info object namespace [cls create obj]]] \
+ [update idletasks] $result [info commands obj]
+} -result {{} {} foo {}}
+test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup {
+ oo::class create cls
+ set result {}
+} -body {
+ oo::define cls {
+ destructor {
+ lappend ::result in destructor
+ [self] destroy
+ }
+ }
+ # This used to crash
+ [cls new] destroy
+ return $result
+} -cleanup {
+ cls destroy
+} -result {in destructor}
test oo-4.1 {basic test of OO functionality: export} {
set o [oo::object new]
@@ -410,6 +702,303 @@ test oo-6.1 {OO: forward} {
foo destroy
return $result
} {1 2}
+test oo-6.2 {OO: forward resolution scope} -setup {
+ oo::class create fooClass
+} -body {
+ proc foo {} {return bad}
+ oo::define fooClass {
+ constructor {} {
+ proc foo {} {return good}
+ }
+ forward bar foo
+ }
+ [fooClass new] bar
+} -cleanup {
+ fooClass destroy
+ rename foo {}
+} -result good
+test oo-6.3 {OO: forward resolution scope} -setup {
+ oo::class create fooClass
+} -body {
+ proc foo {} {return bad}
+ oo::define fooClass {
+ constructor {} {
+ proc foo {} {return good}
+ }
+ }
+ oo::define fooClass forward bar foo
+ [fooClass new] bar
+} -cleanup {
+ fooClass destroy
+ rename foo {}
+} -result good
+test oo-6.4 {OO: forward resolution scope} -setup {
+ oo::class create fooClass
+} -body {
+ proc foo {} {return good}
+ oo::define fooClass {
+ constructor {} {
+ proc foo {} {return bad}
+ }
+ forward bar ::foo
+ }
+ [fooClass new] bar
+} -cleanup {
+ fooClass destroy
+ rename foo {}
+} -result good
+test oo-6.5 {OO: forward resolution scope} -setup {
+ oo::class create fooClass
+ namespace eval foo {}
+} -body {
+ proc foo::foo {} {return good}
+ oo::define fooClass {
+ constructor {} {
+ proc foo {} {return bad}
+ }
+ forward bar foo::foo
+ }
+ [fooClass new] bar
+} -cleanup {
+ fooClass destroy
+ namespace delete foo
+} -result good
+test oo-6.6 {OO: forward resolution scope} -setup {
+ oo::class create fooClass
+ namespace eval foo {}
+} -body {
+ proc foo::foo {} {return bad}
+ oo::define fooClass {
+ constructor {} {
+ namespace eval foo {
+ proc foo {} {return good}
+ }
+ }
+ forward bar foo::foo
+ }
+ [fooClass new] bar
+} -cleanup {
+ fooClass destroy
+ namespace delete foo
+} -result good
+test oo-6.7 {OO: forward resolution scope is per-object} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ constructor {} {
+ proc curns {} {namespace current}
+ }
+ forward ns curns
+ }
+ expr {[[fooClass new] ns] ne [[fooClass new] ns]}
+} -cleanup {
+ fooClass destroy
+} -result 1
+test oo-6.8 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {}
+ }
+ fooClass create ::foo
+ foo test
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.9 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1 2 3
+} -cleanup {
+ fooClass destroy
+} -result 1,2,3
+test oo-6.10 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1 2
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.11 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {}
+ }
+ foo test
+} -returnCodes error -cleanup {
+ foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.12 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ foo test 1 2 3
+} -cleanup {
+ foo destroy
+} -result 1,2,3
+test oo-6.13 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ foo test 1 2
+} -returnCodes error -cleanup {
+ foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.14 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler1 p
+ forward handler1 my handler q
+ method handler {a b c} {}
+ }
+ fooClass create ::foo
+ foo test
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test c"}
+test oo-6.15 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler1 p
+ forward handler1 my handler q
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1
+} -cleanup {
+ fooClass destroy
+} -result q,p,1
+test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test handler1 foo bar
+ forward handler2 my handler x
+ method handler {a b c d} {list $a,$b,$c,$d}
+ export eval
+ }
+ fooClass create ::foo
+ foo eval {
+ interp alias {} [namespace current]::handler1 \
+ {} [namespace current]::my handler2
+ }
+ foo test 1 2 3
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test d"}
+test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test handler1 foo bar boo
+ forward handler2 my handler
+ method handler {a b c d} {list $a,$b,$c,$d}
+ export eval
+ }
+ fooClass create ::foo
+ foo eval {
+ namespace ensemble create \
+ -command [namespace current]::handler1 -parameters {p q} \
+ -map [list boo [list [namespace current]::my handler2]]
+ }
+ foo test 1 2 3
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test c d"}
+test oo-6.18 {Bug 3408830: more forwarding cases} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward len string length
+ }
+ [fooClass create foo] len a b
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "::foo len string"}
+test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup {
+ oo::object create foo
+ unset -nocomplain ::result
+ set ::result {}
+} -body {
+ proc ::my {method} {lappend ::result global}
+ oo::objdefine foo {
+ method target {} {lappend ::result instance}
+ forward bar my target
+ method bump {} {
+ set ns [info object namespace ::foo]
+ rename ${ns}::my ${ns}::
+ rename ${ns}:: ${ns}::my
+ }
+ }
+ proc harness {} {
+ foo target
+ foo bar
+ foo target
+ }
+ trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
+ foo target
+ foo bar
+ foo bump
+ foo bar
+ harness
+} -cleanup {
+ catch {rename harness {}}
+ catch {rename ::my {}}
+ foo destroy
+} -result {instance instance instance instance instance instance}
+test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup {
+ oo::class create fooClass
+ fooClass create foo
+ unset -nocomplain ::result
+ set ::result {}
+} -body {
+ proc ::my {method} {lappend ::result global}
+ oo::define fooClass {
+ method target {} {lappend ::result class}
+ forward bar my target
+ method bump {} {
+ set ns [info object namespace [self]]
+ rename ${ns}::my ${ns}::
+ rename ${ns}:: ${ns}::my
+ }
+ }
+ proc harness {} {
+ foo target
+ foo bar
+ foo target
+ }
+ trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
+ foo target
+ foo bar
+ foo bump
+ foo bar
+ harness
+} -cleanup {
+ catch {rename harness {}}
+ catch {rename ::my {}}
+ fooClass destroy
+} -result {class class class class class class}
test oo-7.1 {OO: inheritance 101} -setup {
oo::class create superClass
@@ -549,6 +1138,7 @@ test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setu
lappend result [Binstance incr x]
lappend result x=$x
} -result {x=10 x 1 returning:11 11 x=11} -cleanup {
+ unset -nocomplain x
Aclass destroy
}
test oo-7.7 {OO: inheritance and errorInfo} -setup {
@@ -594,6 +1184,25 @@ test oo-7.8 {OO: next at the end of the method chain} -setup {
}
lappend result [catch {[foo2 new] bar} msg] $msg
} -result {foo2 foo 1 {no next method implementation}}
+test oo-7.9 {OO: defining inheritance in namespaces} -setup {
+ set ::result {}
+ oo::class create ::master
+ namespace eval ::foo {
+ oo::class create mixin {superclass ::master}
+ }
+} -cleanup {
+ ::master destroy
+ namespace delete ::foo
+} -body {
+ namespace eval ::foo {
+ oo::class create bar {superclass master}
+ oo::class create boo
+ oo::define boo {superclass bar}
+ oo::define boo {mixin mixin}
+ oo::class create spong {superclass boo}
+ return
+ }
+} -result {}
test oo-8.1 {OO: global must work in methods} {
oo::object create foo
@@ -922,6 +1531,20 @@ test oo-13.3 {OO: changing an object's class} -body {
} -cleanup {
foo destroy
} -returnCodes 1 -result {may not change a class object into a non-class object}
+test oo-13.4 {OO: changing an object's class} -body {
+ oo::class create foo {
+ method m {} {
+ set result [list [self class] [info object class [self]]]
+ oo::objdefine [self] class ::bar
+ lappend result [self class] [info object class [self]]
+ }
+ }
+ oo::class create bar
+ [foo new] m
+} -cleanup {
+ foo destroy
+ bar destroy
+} -result {::foo ::foo ::foo ::bar}
# todo: changing a class subtype (metaclass) to another class subtype
test oo-14.1 {OO: mixins} {
@@ -1136,6 +1759,116 @@ test oo-15.3 {OO: class cloning} {
bar destroy
return $result
} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester}
+test oo-15.4 {OO: object cloning - Bug 3474460} -setup {
+ oo::class create ArbitraryClass
+} -body {
+ ArbitraryClass create foo
+ oo::objdefine foo variable a b c
+ oo::copy foo bar
+ info object variable bar
+} -cleanup {
+ ArbitraryClass destroy
+} -result {a b c}
+test oo-15.5 {OO: class cloning - Bug 3474460} -setup {
+ oo::class create ArbitraryClass
+} -body {
+ oo::class create Foo {
+ superclass ArbitraryClass
+ variable a b c
+ }
+ oo::copy Foo Bar
+ info class variable Bar
+} -cleanup {
+ ArbitraryClass destroy
+} -result {a b c}
+test oo-15.6 {OO: object cloning copies namespace contents} -setup {
+ oo::class create ArbitraryClass {export eval}
+} -body {
+ ArbitraryClass create a
+ a eval {proc foo x {
+ variable y
+ return [string repeat $x [incr y]]
+ }}
+ set result [list [a eval {foo 2}] [a eval {foo 3}]]
+ oo::copy a b
+ a eval {rename foo bar}
+ lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}]
+} -cleanup {
+ ArbitraryClass destroy
+} -result {2 33 222 3333 444}
+test oo-15.7 {OO: classes can be cloned anonymously} -setup {
+ oo::class create ArbitraryClassA
+ oo::class create ArbitraryClassB {superclass ArbitraryClassA}
+} -body {
+ info object isa class [oo::copy ArbitraryClassB]
+} -cleanup {
+ ArbitraryClassA destroy
+} -result 1
+test oo-15.8 {OO: intercept object cloning} -setup {
+ oo::class create Foo
+ set result {}
+} -body {
+ oo::define Foo {
+ constructor {msg} {
+ variable v $msg
+ }
+ method <cloned> {from} {
+ next $from
+ lappend ::result cloned $from [self]
+ }
+ method check {} {
+ variable v
+ lappend ::result check [self] $v
+ }
+ }
+ Foo create foo ok
+ oo::copy foo bar
+ foo check
+ bar check
+} -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-15.10 {variable binding must not bleed through oo::copy} -setup {
+ oo::class create FooClass
+ set result {}
+} -body {
+ set obj1 [FooClass new]
+ oo::objdefine $obj1 {
+ variable var
+ method m {} {
+ set var foo
+ }
+ method get {} {
+ return $var
+ }
+ export eval
+ }
+
+ $obj1 m
+ lappend result [$obj1 get]
+ set obj2 [oo::copy $obj1]
+ $obj2 eval {
+ set var bar
+ }
+ lappend result [$obj2 get]
+ $obj1 eval {
+ set var grill
+ }
+ lappend result [$obj1 get] [$obj2 get]
+} -cleanup {
+ FooClass destroy
+} -result {foo bar grill bar}
test oo-16.1 {OO: object introspection} -body {
info object
@@ -1145,7 +1878,7 @@ test oo-16.2 {OO: object introspection} -body {
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
info object gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, mixins, variables, or vars}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
oo::class create meta { superclass oo::class }
[meta create instance1] create instance2
@@ -1186,10 +1919,11 @@ test oo-16.7 {OO: object introspection} -setup {
} -body {
oo::objdefine foo method bar {a {b c} args} {the body}
set result [info object methods foo]
- lappend result [info object definition foo bar]
+ lappend result [info object methodtype foo bar] \
+ [info object definition foo bar]
} -cleanup {
foo destroy
-} -result {bar {{a {b c} args} {the body}}}
+} -result {bar method {{a {b c} args} {the body}}}
test oo-16.8 {OO: object introspection} {
oo::object create foo
oo::class create bar
@@ -1230,10 +1964,26 @@ test oo-16.11 {OO: object introspection} -setup {
} -body {
oo::define foo method spong {} {...}
oo::objdefine bar method boo {a {b c} args} {the body}
- list [info object methods bar -all] [info object methods bar -all -private]
+ list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]]
} -cleanup {
foo destroy
-} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}}
+} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}}
+test oo-16.12 {OO: object introspection} -setup {
+ oo::object create foo
+} -cleanup {
+ rename foo {}
+} -body {
+ oo::objdefine foo unexport {*}[info object methods foo -all]
+ info object methods foo -all
+} -result {}
+test oo-16.13 {OO: object introspection} -setup {
+ oo::object create foo
+} -cleanup {
+ rename foo {}
+} -body {
+ oo::objdefine foo method Bar {} {return "ok in foo"}
+ [info object namespace foo]::my Bar
+} -result "ok in foo"
test oo-17.1 {OO: class introspection} -body {
info class
@@ -1250,7 +2000,7 @@ test oo-17.3 {OO: class introspection} -setup {
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
info class gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, superclasses, or variables}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
@@ -1266,10 +2016,11 @@ test oo-17.6 {OO: class introspection} -setup {
} -body {
oo::define foo method bar {a {b c} args} {the body}
set result [info class methods foo]
- lappend result [info class definition foo bar]
+ lappend result [info class methodtype foo bar] \
+ [info class definition foo bar]
} -cleanup {
foo destroy
-} -result {bar {{a {b c} args} {the body}}}
+} -result {bar method {{a {b c} args} {the body}}}
test oo-17.7 {OO: class introspection} {
info class superclasses oo::class
} ::oo::object
@@ -1297,18 +2048,26 @@ test oo-17.9 {OO: class introspection} -setup {
}
}
oo::define subfoo method boo {a {b c} args} {the body}
- list [info class methods subfoo -all] \
- [info class methods subfoo -all -private]
+ list [lsort [info class methods subfoo -all]] \
+ [lsort [info class methods subfoo -all -private]]
} -cleanup {
foo destroy
-} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}}
+} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}}
+test oo-17.10 {OO: class introspection} -setup {
+ oo::class create foo
+} -cleanup {
+ rename foo {}
+} -body {
+ oo::define foo unexport {*}[info class methods foo -all]
+ info class methods foo -all
+} -result {}
test oo-18.1 {OO: define command support} {
list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
} {1 foo {foo
while executing
"error foo"
- (in definition script for object "oo::object" line 1)
+ (in definition script for class "::oo::object" line 1)
invoked from within
"oo::define oo::object {error foo}"}}
test oo-18.2 {OO: define command support} {
@@ -1321,9 +2080,39 @@ test oo-18.3 {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 1)
+ (in definition script for class "::foo" line 1)
invoked from within
"oo::class create foo {error bar}"}}
+test oo-18.3a {OO: define command support} {
+ list [catch {oo::class create foo {
+ error bar
+}} msg] $msg $errorInfo
+} {1 bar {bar
+ while executing
+"error bar"
+ (in definition script for class "::foo" line 2)
+ invoked from within
+"oo::class create foo {
+ error bar
+}"}}
+test oo-18.3b {OO: define command support} {
+ list [catch {oo::class create foo {
+ eval eval error bar
+}} msg] $msg $errorInfo
+} {1 bar {bar
+ while executing
+"error bar"
+ ("eval" body line 1)
+ invoked from within
+"eval error bar"
+ ("eval" body line 1)
+ invoked from within
+"eval eval error bar"
+ (in definition script for class "::foo" line 2)
+ invoked from within
+"oo::class create foo {
+ eval eval error bar
+}"}}
test oo-18.4 {OO: more error traces from the guts} -setup {
oo::object create obj
} -body {
@@ -1374,11 +2163,112 @@ test oo-18.5 {OO: more error traces from the guts} -setup {
(class "::cls" method "eval" line 1)
invoked from within
"obj eval {error bar}"}}
+test oo-18.6 {class construction reference management and errors} -setup {
+ oo::class create super_abc
+} -body {
+ catch {
+oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}
+ } msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ super_abc destroy
+} -result {foo
+ while executing
+"::error foo"
+ (in definition script for class "::def" line 4)
+ invoked from within
+"oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}"}
+test oo-18.7 {OO: objdefine command support} -setup {
+ oo::object create ::inst
+} -body {
+ list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo
+} -cleanup {
+ catch {::inst destroy}
+ catch {::INST destroy}
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in definition script for object "::INST" line 1)
+ invoked from within
+"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
+test oo-18.8 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::bar" line 1)
+ invoked from within
+"self {error foobar}"
+ (in definition script for class "::bar" line 1)
+ invoked from within
+"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
+test oo-18.9 {OO: define/self command support} -setup {
+ oo::class create master
+ set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
+ superclass master
+ }]
+} -body {
+ catch {oo::define $c {error err}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {err
+ while executing
+"error err"
+ (in definition script for class "::now_this_is_a_very_very_long..." line 1)
+ invoked from within
+"oo::define $c {error err}"}
+test oo-18.10 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::foo" line 1)
+ invoked from within
+"self {rename ::foo {}; error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {self {rename ::foo {}; error foobar}}"}
+test oo-18.11 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {this command cannot be called when the object has been deleted
+ while executing
+"self {error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {rename ::foo {}; self {error foobar}}"}
test oo-19.1 {OO: varname method} -setup {
oo::object create inst
oo::objdefine inst export eval
set result {}
+ inst eval { variable x }
} -body {
inst eval {trace add variable x write foo}
set ns [inst eval namespace current]
@@ -1396,6 +2286,36 @@ test oo-19.1 {OO: varname method} -setup {
inst destroy
rename foo {}
} -result {{x {} write} ok ok 0}
+test oo-19.2 {OO: varname method: Bug 2883857} -setup {
+ oo::class create SpecialClass
+ oo::objdefine SpecialClass export createWithNamespace
+ SpecialClass createWithNamespace inst ::oo_test
+ oo::objdefine inst export varname eval
+} -body {
+ inst eval { variable x; array set x {y z} }
+ inst varname x(y)
+} -cleanup {
+ SpecialClass destroy
+} -result ::oo_test::x(y)
+test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup {
+ oo::class create testClass {
+ variable foo
+ export varname
+ constructor {} {
+ variable foo x
+ }
+ method bar {obj} {
+ my varname foo
+ $obj varname foo
+ }
+ }
+} -body {
+ testClass create A
+ testClass create B
+ lsearch [list [A varname foo] [B varname foo]] [B bar A]
+} -cleanup {
+ testClass destroy
+} -result 0
test oo-20.1 {OO: variable method} -body {
oo::class create testClass {
@@ -1574,6 +2494,51 @@ test oo-20.12 {OO: variable method accept zero args (TIP 323)} -setup {
}
foo demo
} -result {}
+test oo-20.13 {OO: variable method use in non-methods [Bug 2903811]} -setup {
+ oo::object create fooObj
+ oo::objdefine fooObj export variable
+} -cleanup {
+ fooObj destroy
+} -body {
+ apply {{} {fooObj variable x; set x ok; return}}
+ apply {{} {fooObj variable x; return $x}}
+} -result ok
+test oo-20.14 {OO: variable method use in non-methods [Bug 2903811]} -setup {
+ oo::object create fooObj
+ oo::objdefine fooObj export variable
+ namespace eval ns1 {}
+ namespace eval ns2 {}
+ set x bad
+} -cleanup {
+ fooObj destroy
+ namespace delete ns1 ns2
+ unset x
+} -body {
+ namespace eval ns1 {fooObj variable x; set x ok; subst ""}
+ set x bad
+ namespace eval ns2 {fooObj variable x; return $x}
+} -result ok
+test oo-20.15 {OO: variable method use in non-methods [Bug 2903811]} -setup {
+ oo::object create fooObj
+ oo::objdefine fooObj export variable varname
+} -cleanup {
+ fooObj destroy
+} -body {
+ apply {{} {fooObj variable x; set x ok; return}}
+ return [set [fooObj varname x]]
+} -result ok
+test oo-20.16 {variable method: leak per instance} -setup {
+ oo::class create foo
+} -constraints memory -body {
+ oo::define foo {
+ constructor {} {
+ set [my variable v] 0
+ }
+ }
+ leaktest {[foo new] destroy}
+} -cleanup {
+ foo destroy
+} -result 0
test oo-21.1 {OO: inheritance ordering} -setup {
oo::class create A
@@ -1740,7 +2705,19 @@ test oo-22.1 {OO and info frame} -setup {
list [i level] [i frames] [dict get [c frame] object]
} -cleanup {
c destroy
-} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}
+} -result {1 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c}
+test oo-22.2 {OO and info frame: Bug 3001438} -setup {
+ oo::class create c
+} -body {
+ oo::define c method test {{x 1}} {
+ if {$x} {my test 0}
+ lsort {q w e r t y u i o p}; # Overwrite the Tcl stack
+ info frame 0
+ }
+ [c new] test
+} -match glob -cleanup {
+ c destroy
+} -result {* cmd {info frame 0} method test class ::c level 0}
# Prove that the issue in [Bug 1865054] isn't an issue any more
test oo-23.1 {Self-like derivation; complex case!} -setup {
@@ -1799,6 +2776,16 @@ test oo-24.2 {unknown method method - Bug 1965063} -setup {
}
obj foo bar
} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
+test oo-24.3 {unknown method method - absent method name} -setup {
+ set o [oo::object new]
+} -cleanup {
+ $o destroy
+} -body {
+ oo::objdefine $o method unknown args {
+ return "unknown: >>$args<<"
+ }
+ list [$o] [$o foobar] [$o foo bar]
+} -result {{unknown: >><<} {unknown: >>foobar<<} {unknown: >>foo bar<<}}
# Probably need a better set of tests, but this is quite difficult to devise
test oo-25.1 {call chain caching} -setup {
@@ -2061,7 +3048,462 @@ test oo-27.11 {variables declaration - no instance var leaks with class resolver
inst1 step
list [inst1 value] [inst2 value]
} -result {3 2}
+test oo-27.12 {variables declaration: leak per instance} -setup {
+ oo::class create foo
+} -constraints memory -body {
+ oo::define foo {
+ variable v
+ constructor {} {
+ set v 0
+ }
+ }
+ leaktest {[foo new] destroy}
+} -cleanup {
+ foo destroy
+} -result 0
+# This test will actually (normally) crash if it fails!
+test oo-27.13 {variables declaration: Bug 3185009: require refcount management} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ variable x
+ method set v {set x $v}
+ method unset {} {unset x}
+ method exists {} {info exists x}
+ method get {} {return $x}
+ }
+ list [foo exists] [foo set 7] [foo exists] [foo get] [foo unset] \
+ [foo exists] [catch {foo get} msg] $msg
+} -cleanup {
+ foo destroy
+} -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}}
+test oo-27.14 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.15 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable
+ variable x y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.16 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -clear
+ variable y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.17 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -set y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ foo create bar
+ list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.18 {variables declaration - multiple use} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x
+ variable -? y
+ method boo {} {
+ return [incr x],[incr y]
+ }
+ }
+ 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...
+test oo-28.1 {scripted extensions to oo::define} -setup {
+ interp create foo
+ foo eval {oo::class create cls {export eval}}
+} -cleanup {
+ interp delete foo
+} -body {
+ foo eval {
+ proc oo::define::privateMethod {name arguments body} {
+ uplevel 1 [list method $name $arguments $body]
+ uplevel 1 [list unexport $name]
+ }
+ oo::define cls privateMethod m {x y} {return $x,$y}
+ cls create obj
+ list [catch {obj m 1 2}] [obj eval my m 3 4]
+ }
+} -result {1 3,4}
+test oo-29.1 {self class with object-defined methods} -setup {
+ oo::object create obj
+} -body {
+ oo::objdefine obj method demo {} {
+ self class
+ }
+ obj demo
+} -returnCodes error -cleanup {
+ obj destroy
+} -result {method not defined by a class}
+
+test oo-30.1 {Bug 2903011: deleting an object in a constructor} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {constructor {} {[self] destroy}}
+ cls new
+} -returnCodes error -cleanup {
+ cls destroy
+} -result {object deleted in constructor}
+test oo-30.2 {Bug 2903011: deleting an object in a constructor} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {constructor {} {my destroy}}
+ cls new
+} -returnCodes error -cleanup {
+ cls destroy
+} -result {object deleted in constructor}
+
+test oo-31.1 {Bug 3111059: when objects and coroutines entangle} -setup {
+ oo::class create cls
+} -constraints memory -body {
+ oo::define cls {
+ method justyield {} {
+ yield
+ }
+ constructor {} {
+ coroutine coro my justyield
+ }
+ }
+ list [leaktest {[cls new] destroy}] [info class instances cls]
+} -cleanup {
+ cls destroy
+} -result {0 {}}
+test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
+ oo::class create cls
+} -constraints memory -body {
+ oo::define cls {
+ method justyield {} {
+ yield
+ }
+ constructor {} {
+ coroutine coro my justyield
+ }
+ destructor {
+ rename coro {}
+ }
+ }
+ list [leaktest {[cls new] destroy}] [info class instances cls]
+} -cleanup {
+ cls destroy
+} -result {0 {}}
+
+oo::class create SampleSlot {
+ superclass oo::Slot
+ constructor {} {
+ variable contents {a b c} ops {}
+ }
+ method contents {} {variable contents; return $contents}
+ method ops {} {variable ops; return $ops}
+ method Get {} {
+ variable contents
+ variable ops
+ lappend ops [info level] Get
+ return $contents
+ }
+ method Set {lst} {
+ variable contents $lst
+ variable ops
+ lappend ops [info level] Set $lst
+ return
+ }
+}
+
+test oo-32.1 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -clear] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -append g h i] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -set d e f] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+
+test oo-33.1 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ list [$s x y] [$s contents]
+} -cleanup {
+ rename $s {}
+} -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ list [$s destroy; $s unknown] [$s contents]
+} -cleanup {
+ rename $s {}
+} -result {{} {a b c destroy unknown}}
+test oo-33.3 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ oo::objdefine $s forward --default-operation my -set
+ list [$s destroy; $s unknown] [$s contents] [$s ops]
+} -cleanup {
+ rename $s {}
+} -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup {
+ set s [SampleSlot new]
+} -body {
+ # Method names beginning with "-" are special to slots
+ $s -grill q
+} -returnCodes error -cleanup {
+ rename $s {}
+} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
+
+SampleSlot destroy
+
+test oo-34.1 {TIP 380: slots - presence} -setup {
+ set obj [oo::object new]
+ set result {}
+} -body {
+ oo::define oo::object {
+ ::lappend ::result [::info object class filter]
+ ::lappend ::result [::info object class mixin]
+ ::lappend ::result [::info object class superclass]
+ ::lappend ::result [::info object class variable]
+ }
+ oo::objdefine $obj {
+ ::lappend ::result [::info object class filter]
+ ::lappend ::result [::info object class mixin]
+ ::lappend ::result [::info object class variable]
+ }
+ return $result
+} -cleanup {
+ $obj destroy
+} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
+test oo-34.2 {TIP 380: slots - presence} {
+ lsort [info class instances oo::Slot]
+} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
+proc getMethods obj {
+ list [lsort [info object methods $obj -all]] \
+ [lsort [info object methods $obj -private]]
+}
+test oo-34.3 {TIP 380: slots - presence} {
+ getMethods oo::define::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.4 {TIP 380: slots - presence} {
+ getMethods oo::define::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.5 {TIP 380: slots - presence} {
+ getMethods oo::define::superclass
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.6 {TIP 380: slots - presence} {
+ getMethods oo::define::variable
+} {{-append -clear -set} {Get Set}}
+test oo-34.7 {TIP 380: slots - presence} {
+ getMethods oo::objdefine::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.8 {TIP 380: slots - presence} {
+ getMethods oo::objdefine::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+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
generated by cgit v0.12 at 2025-11-17 03:44:18 (GMT)