summaryrefslogtreecommitdiffstats
path: root/tests/oo.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/oo.test')
-rw-r--r--tests/oo.test2677
1 files changed, 2677 insertions, 0 deletions
diff --git a/tests/oo.test b/tests/oo.test
new file mode 100644
index 0000000..b12cb42
--- /dev/null
+++ b/tests/oo.test
@@ -0,0 +1,2677 @@
+# This file contains a collection of tests for Tcl's built-in object system.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2006-2011 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require -exact TclOO 0.6.3 ;# Must match value in generic/tclOO.h
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
+ namespace import -force ::tcltest::*
+}
+
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+ proc getbytes {} {
+ set lines [split [memory info] \n]
+ return [lindex $lines 3 3]
+ }
+ proc leaktest {script {iterations 3}} {
+ set end [getbytes]
+ for {set i 0} {$i < $iterations} {incr i} {
+ uplevel 1 $script
+ set tmp $end
+ set end [getbytes]
+ }
+ return [expr {$end - $tmp}]
+ }
+}
+
+test oo-0.1 {basic test of OO's ability to clean up its initial state} {
+ interp create t
+ t eval {
+ package require TclOO
+ }
+ interp delete t
+} {}
+test oo-0.2 {basic test of OO's ability to clean up its initial state} {
+ set i [interp create]
+ 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 {
+ [oo::object new] destroy
+ }
+} -constraints memory -result 0
+test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
+ leaktest {
+ oo::class create foo
+ foo new
+ foo destroy
+ }
+} -constraints memory -result 0
+test oo-0.5 {testing literal leak on interp delete} memory {
+ leaktest {
+ interp create foo
+ foo eval {oo::object new}
+ 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::version $::oo::version]
+
+test oo-1.1 {basic test of OO functionality: no classes} {
+ set result {}
+ lappend result [oo::object create foo]
+ lappend result [oo::objdefine foo {
+ method bar args {
+ global result
+ lappend result {*}$args
+ return [llength $args]
+ }
+ }]
+ lappend result [foo bar a b c]
+ lappend result [foo destroy] [info commands foo]
+} {::foo {} a b c 3 {} {}}
+test oo-1.2 {basic test of OO functionality: no classes} -body {
+ oo::define oo::object method missingArgs
+} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\""
+test oo-1.3 {basic test of OO functionality: no classes} {
+ catch {oo::define oo::object method missingArgs}
+ set errorInfo
+} "wrong # args: should be \"oo::define oo::object method name args body\"
+ while executing
+\"oo::define oo::object method missingArgs\""
+test oo-1.4 {basic test of OO functionality} -body {
+ oo::object create {}
+} -returnCodes 1 -result {object name must not be empty}
+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.6 {basic test of OO functionality} -setup {
+ oo::object create aninstance
+} -body {
+ oo::objdefine aninstance unexport destroy
+ aninstance doesnotexist
+} -cleanup {
+ rename aninstance {}
+} -returnCodes 1 -result {object "::aninstance" has no visible methods}
+test oo-1.7 {basic test of OO functionality} -setup {
+ oo::object create aninstance
+} -body {
+ oo::objdefine aninstance {
+ # Do not do this in real code! Ever! This is *not* supported!
+ ::oo::define::method ha ha ha
+ }
+} -returnCodes error -cleanup {
+ aninstance destroy
+} -result {attempt to misuse API}
+test oo-1.8 {basic test of OO functionality} -setup {
+ oo::object create obj
+ set result {}
+} -cleanup {
+ obj destroy
+} -body {
+ oo::objdefine obj method foo {} {return bar}
+ lappend result [obj foo]
+ oo::objdefine obj method foo {} {}
+ lappend result [obj foo]
+} -result {bar {}}
+test oo-1.9 {basic test of OO functionality} -setup {
+ oo::object create a
+ oo::object create b
+} -cleanup {
+ catch {a destroy}
+ b destroy
+} -body {
+ oo::objdefine a method foo {} { return A }
+ oo::objdefine b method foo {} { return B }
+ apply {{} {
+ set m foo
+ return [a $m],[a destroy],[b $m]
+ }}
+} -result A,,B
+test oo-1.10 {basic test of OO functionality} -body {
+ namespace eval foo {
+ namespace eval bar {
+ oo::object create o
+ namespace export o
+ }
+ namespace import bar::o
+ }
+ list [info object isa object foo::bar::o] [info object isa object foo::o]
+} -cleanup {
+ namespace delete foo
+} -result {1 1}
+test oo-1.11 {basic test of OO functionality: abbreviating} -setup {
+ oo::class create c
+} -cleanup {
+ c destroy
+} -body {
+ oo::define c super oo::class
+ info class super c
+} -result ::oo::class
+test oo-1.12 {basic test of OO functionality: abbreviating} -setup {
+ oo::class create c
+} -cleanup {
+ c destroy
+} -body {
+ oo::define c {super oo::class}
+ info class super c
+} -result ::oo::class
+test oo-1.13 {basic test of OO functionality: abbreviating} -setup {
+ oo::class create c
+} -cleanup {
+ c destroy
+} -body {
+ oo::define c self {forw a b}
+ info object forw c a
+} -result b
+test oo-1.14 {basic test of OO functionality: abbreviating} -setup {
+ oo::class create c
+} -cleanup {
+ c destroy
+} -body {
+ oo::define c self forw a b
+ info object forw c a
+} -result b
+test oo-1.15 {basic test of OO functionality: abbreviating} -setup {
+ oo::object create o
+} -cleanup {
+ o destroy
+} -body {
+ oo::objdefine o {forw a b}
+ info object forw o a
+} -result b
+test oo-1.16 {basic test of OO functionality: abbreviating} -setup {
+ oo::object create o
+} -cleanup {
+ o destroy
+} -body {
+ 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
+ subinterp eval {
+ package require TclOO
+ }
+} -body {
+ subinterp eval {
+ oo::define oo::object constructor {} {
+ lappend ::result [info level 0]
+ }
+ lappend result 1
+ lappend result 2 [oo::object create foo]
+ }
+} -cleanup {
+ interp delete subinterp
+} -result {1 {oo::object create foo} 2 ::foo}
+test oo-2.2 {basic test of OO functionality: constructor} {
+ oo::class create testClass {
+ constructor {} {
+ global result
+ lappend result "[self]->construct"
+ }
+ method bar {} {
+ global result
+ lappend result "[self]->bar"
+ }
+ }
+ set result {}
+ [testClass create foo] bar
+ 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-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
+ interp create subinterp
+ subinterp eval {
+ package require TclOO
+ }
+} -body {
+ subinterp eval {
+ oo::define oo::object destructor {
+ lappend ::result died
+ }
+ lappend result 1 [oo::object create foo]
+ lappend result 2 [rename foo {}]
+ oo::define oo::object destructor {}
+ return $result
+ }
+} -cleanup {
+ interp delete subinterp
+} -result {1 ::foo died 2 {}}
+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
+ subinterp eval {
+ package require TclOO
+ }
+} -body {
+ subinterp eval {
+ oo::define oo::object destructor {
+ lappend ::result died
+ }
+ lappend result 1 [oo::object create foo]
+ lappend result 2 [rename foo {}]
+ }
+} -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]
+ set result {}
+ oo::objdefine $o method Foo {} {lappend ::result Foo; return}
+ lappend result [catch {$o Foo} msg] $msg
+ oo::objdefine $o export Foo
+ lappend result [$o Foo] [$o destroy]
+} {1 {unknown method "Foo": must be destroy} Foo {} {}}
+test oo-4.2 {basic test of OO functionality: unexport} {
+ set o [oo::object new]
+ set result {}
+ oo::objdefine $o method foo {} {lappend ::result foo; return}
+ lappend result [$o foo]
+ oo::objdefine $o unexport foo
+ lappend result [catch {$o foo} msg] $msg [$o destroy]
+} {foo {} 1 {unknown method "foo": must be destroy} {}}
+test oo-4.3 {exporting and error messages, Bug 1824958} -setup {
+ oo::class create testClass
+} -cleanup {
+ testClass destroy
+} -body {
+ oo::define testClass self export Bad
+ testClass Bad
+} -returnCodes 1 -result {unknown method "Bad": must be create, destroy or new}
+test oo-4.4 {exporting a class method from an object} -setup {
+ oo::class create testClass
+ testClass create testObject
+} -cleanup {
+ testClass destroy
+} -body {
+ oo::define testClass method Good {} { return ok }
+ oo::objdefine testObject export Good
+ testObject Good
+} -result ok
+test oo-4.5 {export creates proper method entries} -setup {
+ oo::class create testClass
+} -body {
+ oo::define testClass {
+ export foo
+ method foo {} {return ok}
+ }
+ [testClass new] foo
+} -cleanup {
+ testClass destroy
+} -result ok
+test oo-4.6 {export creates proper method entries} -setup {
+ oo::class create testClass
+} -body {
+ oo::define testClass {
+ unexport foo
+ method foo {} {return ok}
+ }
+ [testClass new] foo
+} -cleanup {
+ testClass destroy
+} -result ok
+
+test oo-5.1 {OO: manipulation of classes as objects} -setup {
+ set obj [oo::object new]
+} -body {
+ oo::objdefine oo::object method foo {} { return "in object" }
+ catch {$obj foo} result
+ list [catch {$obj foo} result] $result [oo::object foo]
+} -cleanup {
+ oo::objdefine oo::object deletemethod foo
+ $obj destroy
+} -result {1 {unknown method "foo": must be destroy} {in object}}
+test oo-5.2 {OO: manipulation of classes as objects} -setup {
+ set obj [oo::object new]
+} -body {
+ oo::define oo::object self method foo {} { return "in object" }
+ catch {$obj foo} result
+ list [catch {$obj foo} result] $result [oo::object foo]
+} -cleanup {
+ oo::objdefine oo::object deletemethod foo
+ $obj destroy
+} -result {1 {unknown method "foo": must be destroy} {in object}}
+test oo-5.3 {OO: manipulation of classes as objects} -setup {
+ set obj [oo::object new]
+} -body {
+ oo::objdefine oo::object {
+ method foo {} { return "in object" }
+ }
+ catch {$obj foo} result
+ list [catch {$obj foo} result] $result [oo::object foo]
+} -cleanup {
+ oo::objdefine oo::object deletemethod foo
+ $obj destroy
+} -result {1 {unknown method "foo": must be destroy} {in object}}
+test oo-5.4 {OO: manipulation of classes as objects} -setup {
+ set obj [oo::object new]
+} -body {
+ oo::define oo::object {
+ self method foo {} { return "in object" }
+ }
+ catch {$obj foo} result
+ list [catch {$obj foo} result] $result [oo::object foo]
+} -cleanup {
+ oo::objdefine oo::object deletemethod foo
+ $obj destroy
+} -result {1 {unknown method "foo": must be destroy} {in object}}
+test oo-5.5 {OO: manipulation of classes as objects} -setup {
+ set obj [oo::object new]
+} -body {
+ oo::define oo::object {
+ self {
+ method foo {} { return "in object" }
+ }
+ }
+ catch {$obj foo} result
+ list [catch {$obj foo} result] $result [oo::object foo]
+} -cleanup {
+ oo::objdefine oo::object deletemethod foo
+ $obj destroy
+} -result {1 {unknown method "foo": must be destroy} {in object}}
+
+test oo-6.1 {OO: forward} {
+ oo::object create foo
+ oo::objdefine foo {
+ forward a lappend
+ forward b lappend result
+ }
+ set result {}
+ foo a result 1
+ foo b 2
+ 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-7.1 {OO: inheritance 101} -setup {
+ oo::class create superClass
+ oo::class create subClass
+ subClass create instance
+} -body {
+ oo::define superClass method doit x {lappend ::result $x}
+ oo::define subClass superclass superClass
+ set result [list [catch {subClass doit bad} msg] $msg]
+ instance doit ok
+ return $result
+} -cleanup {
+ subClass destroy
+ superClass destroy
+} -result {1 {unknown method "doit": must be create, destroy or new} ok}
+test oo-7.2 {OO: inheritance 101} -setup {
+ oo::class create superClass
+ oo::class create subClass
+ subClass create instance
+} -body {
+ oo::define superClass method doit x {
+ lappend ::result |$x|
+ }
+ oo::define subClass superclass superClass
+ oo::objdefine instance method doit x {
+ lappend ::result =$x=
+ next [incr x]
+ }
+ set result {}
+ instance doit 1
+ return $result
+} -cleanup {
+ subClass destroy
+ superClass destroy
+} -result {=1= |2|}
+test oo-7.3 {OO: inheritance 101} -setup {
+ oo::class create superClass
+ oo::class create subClass
+ subClass create instance
+} -body {
+ oo::define superClass method doit x {
+ lappend ::result |$x|
+ }
+ oo::define subClass {
+ superclass superClass
+ method doit x {lappend ::result -$x-; next [incr x]}
+ }
+ oo::objdefine instance method doit x {
+ lappend ::result =$x=;
+ next [incr x]
+ }
+ set result {}
+ instance doit 1
+ return $result
+} -cleanup {
+ subClass destroy
+ superClass destroy
+} -result {=1= -2- |3|}
+test oo-7.4 {OO: inheritance from oo::class} -body {
+ oo::class create meta {
+ superclass oo::class
+ self {
+ unexport create new
+ method make {x {definitions {}}} {
+ if {![string match ::* $x]} {
+ set ns [uplevel 1 {::namespace current}]
+ set x ${ns}::$x
+ }
+ set o [my create $x]
+ lappend ::result "made $o"
+ oo::define $o $definitions
+ return $o
+ }
+ }
+ }
+ set result [list [catch {meta create foo} msg] $msg]
+ lappend result [meta make classinstance {
+ lappend ::result "in definition script in [namespace current]"
+ }]
+ lappend result [classinstance create instance]
+} -cleanup {
+ catch {classinstance destroy}
+ catch {meta destroy}
+} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
+test oo-7.5 {OO: inheritance from oo::class in the secondary chain} -body {
+ oo::class create other
+ oo::class create meta {
+ superclass other oo::class
+ self {
+ unexport create new
+ method make {x {definitions {}}} {
+ if {![string match ::* $x]} {
+ set ns [uplevel 1 {::namespace current}]
+ set x ${ns}::$x
+ }
+ set o [my create $x]
+ lappend ::result "made $o"
+ oo::define $o $definitions
+ return $o
+ }
+ }
+ }
+ set result [list [catch {meta create foo} msg] $msg]
+ lappend result [meta make classinstance {
+ lappend ::result "in definition script in [namespace current]"
+ }]
+ lappend result [classinstance create instance]
+} -cleanup {
+ catch {classinstance destroy}
+ catch {meta destroy}
+ catch {other destroy}
+} -result {1 {unknown method "create": must be destroy or make} {made ::classinstance} {in definition script in ::oo::define} ::classinstance ::instance}
+test oo-7.6 {OO: inheritance 101 - overridden methods should be oblivious} -setup {
+ oo::class create Aclass
+ oo::class create Bclass
+ Bclass create Binstance
+} -body {
+ oo::define Aclass {
+ method incr {var step} {
+ upvar 1 $var v
+ ::incr v $step
+ }
+ }
+ oo::define Bclass {
+ superclass Aclass
+ method incr {var {step 1}} {
+ global result
+ lappend result $var $step
+ set r [next $var $step]
+ lappend result returning:$r
+ return $r
+ }
+ }
+ set result {}
+ set x 10
+ lappend result x=$x
+ 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 {
+ oo::class create A
+ oo::class create B
+ B create c
+} -body {
+ oo::define A method foo {} {error foo!}
+ oo::define B {
+ superclass A
+ method foo {} { next }
+ }
+ oo::objdefine c method foo {} { next }
+ catch {c ?} msg
+ set result [list $msg]
+ catch {c foo} msg
+ lappend result $msg $errorInfo
+} -cleanup {
+ A destroy
+} -result {{unknown method "?": must be destroy or foo} foo! {foo!
+ while executing
+"error foo!"
+ (class "::A" method "foo" line 1)
+ invoked from within
+"next "
+ (class "::B" method "foo" line 1)
+ invoked from within
+"next "
+ (object "::c" method "foo" line 1)
+ invoked from within
+"c foo"}}
+test oo-7.8 {OO: next at the end of the method chain} -setup {
+ set ::result ""
+} -cleanup {
+ foo destroy
+} -body {
+ oo::class create foo {
+ method bar {} {lappend ::result foo; lappend ::result [next] foo}
+ }
+ oo::class create foo2 {
+ superclass foo
+ method bar {} {lappend ::result foo2; lappend ::result [next] foo2}
+ }
+ 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
+ oo::objdefine foo method bar x {global result; lappend result $x}
+ set result {}
+ foo bar this
+ foo bar is
+ lappend result a
+ foo bar test
+ foo destroy
+ return $result
+} {this is a test}
+
+test oo-9.1 {OO: multiple inheritance} -setup {
+ oo::class create A
+ oo::class create B
+ oo::class create C
+ oo::class create D
+ D create foo
+} -body {
+ oo::define A method test {} {lappend ::result A; return ok}
+ oo::define B {
+ superclass A
+ method test {} {lappend ::result B; next}
+ }
+ oo::define C {
+ superclass A
+ method test {} {lappend ::result C; next}
+ }
+ oo::define D {
+ superclass B C
+ method test {} {lappend ::result D; next}
+ }
+ set result {}
+ lappend result [foo test]
+} -cleanup {
+ D destroy
+ C destroy
+ B destroy
+ A destroy
+} -result {D B C A ok}
+test oo-9.2 {OO: multiple inheritance} -setup {
+ oo::class create A
+ oo::class create B
+ oo::class create C
+ oo::class create D
+ D create foo
+} -body {
+ oo::define A method test {} {lappend ::result A; return ok}
+ oo::define B {
+ superclass A
+ method test {} {lappend ::result B; next}
+ }
+ oo::define C {
+ superclass A
+ method test {} {lappend ::result C; next}
+ }
+ oo::define D {
+ superclass B C
+ method test {} {lappend ::result D; next}
+ }
+ set result {}
+ lappend result [foo test]
+} -cleanup {
+ A destroy
+} -result {D B C A ok}
+
+test oo-10.1 {OO: recursive invoke and modify} -setup {
+ [oo::class create C] create O
+} -cleanup {
+ C destroy
+} -body {
+ oo::define C method foo x {
+ lappend ::result $x
+ if {$x} {
+ [self object] foo [incr x -1]
+ }
+ }
+ oo::objdefine O method foo x {
+ lappend ::result -$x-
+ if {$x == 1} {
+ oo::objdefine O deletemethod foo
+ }
+ next $x
+ }
+ set result {}
+ O foo 2
+ return $result
+} -result {-2- 2 -1- 1 0}
+test oo-10.2 {OO: recursive invoke and modify} -setup {
+ oo::object create O
+} -cleanup {
+ O destroy
+} -body {
+ oo::objdefine O method foo {} {
+ oo::objdefine [self] method foo {} {
+ error "not called"
+ }
+ return [format %s%s call ed]
+ }
+ O foo
+} -result called
+test oo-10.3 {OO: invoke and modify} -setup {
+ oo::class create A {
+ method a {} {return A.a}
+ method b {} {return A.b}
+ method c {} {return A.c}
+ }
+ oo::class create B {
+ superclass A
+ method a {} {return [next],B.a}
+ method b {} {return [next],B.b}
+ method c {} {return [next],B.c}
+ }
+ B create C
+ set result {}
+} -cleanup {
+ A destroy
+} -body {
+ lappend result [C a] [C b] [C c] -
+ oo::define B deletemethod b
+ lappend result [C a] [C b] [C c] -
+ oo::define B renamemethod a b
+ lappend result [C a] [C b] [C c] -
+ oo::define B deletemethod b c
+ lappend result [C a] [C b] [C c]
+} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
+
+test oo-11.1 {OO: cleanup} {
+ oo::object create foo
+ set result [list [catch {oo::object create foo} msg] $msg]
+ lappend result [foo destroy] [oo::object create foo] [foo destroy]
+} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
+test oo-11.2 {OO: cleanup} {
+ oo::class create bar
+ bar create foo
+ set result [list [catch {bar create foo} msg] $msg]
+ lappend result [bar destroy] [oo::object create foo] [foo destroy]
+} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
+test oo-11.3 {OO: cleanup} {
+ oo::class create bar0
+ oo::class create bar
+ oo::define bar superclass bar0
+ bar create foo
+ set result [list [catch {bar create foo} msg] $msg]
+ lappend result [bar0 destroy] [oo::object create foo] [foo destroy]
+} {1 {can't create object "foo": command already exists with that name} {} ::foo {}}
+test oo-11.4 {OO: cleanup} {
+ oo::class create bar0
+ oo::class create bar1
+ oo::define bar1 superclass bar0
+ oo::class create bar2
+ oo::define bar2 {
+ superclass bar0
+ destructor {lappend ::result destroyed}
+ }
+ oo::class create bar
+ oo::define bar superclass bar1 bar2
+ bar create foo
+ set result [list [catch {bar create foo} msg] $msg]
+ lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \
+ [oo::object create bar2] [bar2 destroy]
+} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}}
+
+test oo-12.1 {OO: filters} {
+ oo::class create Aclass
+ Aclass create Aobject
+ oo::define Aclass {
+ method concatenate args {
+ global result
+ lappend result {*}$args
+ join $args {}
+ }
+ method logFilter args {
+ global result
+ lappend result "calling [self object]->[self method] $args"
+ set r [next {*}$args]
+ lappend result "result=$r"
+ return $r
+ }
+ }
+ oo::objdefine Aobject filter logFilter
+ set result {}
+ lappend result [Aobject concatenate 1 2 3 4 5]
+ Aclass destroy
+ return $result
+} {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 12345}
+test oo-12.2 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method concatenate args {
+ global result
+ lappend result {*}$args
+ join $args {}
+ }
+ method logFilter args {
+ global result
+ lappend result "calling [self object]->[self method] $args"
+ set r [next {*}$args]
+ lappend result "result=$r"
+ return $r
+ }
+ }
+ oo::objdefine Aobject filter logFilter
+ set result {}
+ lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
+} -cleanup {
+ Aclass destroy
+} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
+test oo-12.3 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method concatenate args {
+ global result
+ lappend result {*}$args
+ join $args {}
+ }
+ method logFilter args {
+ global result
+ lappend result "calling [self object]->[self method] $args"
+ set r [next {*}$args]
+ lappend result "result=$r"
+ return $r
+ }
+ filter logFilter
+ }
+ set result {}
+ lappend result [Aobject concatenate 1 2 3 4 5] [Aobject destroy]
+} -cleanup {
+ Aclass destroy
+} -result {{calling ::Aobject->logFilter 1 2 3 4 5} 1 2 3 4 5 result=12345 {calling ::Aobject->logFilter } result= 12345 {}}
+test oo-12.4 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method foo {} { return foo }
+ method Bar {} { return 1 }
+ method boo {} { if {[my Bar]} { next } { error forbidden } }
+ filter boo
+ }
+ Aobject foo
+} -cleanup {
+ Aclass destroy
+} -result foo
+test oo-12.5 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method foo {} { return foo }
+ method Bar {} { return [my Bar2] }
+ method Bar2 {} { return 1 }
+ method boo {} { if {[my Bar]} { next } { error forbidden } }
+ filter boo
+ }
+ Aobject foo
+} -cleanup {
+ Aclass destroy
+} -result foo
+test oo-12.6 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method foo {} { return foo }
+ method Bar {} { return [my Bar2] }
+ method Bar2 {} { return [my Bar3] }
+ method Bar3 {} { return 1 }
+ method boo {} { if {[my Bar]} { next } { error forbidden } }
+ filter boo
+ }
+ Aobject foo
+} -cleanup {
+ Aclass destroy
+} -result foo
+test oo-12.7 {OO: filters} -setup {
+ oo::class create Aclass
+ Aclass create Aobject
+} -body {
+ oo::define Aclass {
+ method outerfoo {} { return [my InnerFoo] }
+ method InnerFoo {} { return foo }
+ method Bar {} { return [my Bar2] }
+ method Bar2 {} { return [my Bar3] }
+ method Bar3 {} { return 1 }
+ method boo {} {
+ lappend ::log [self target]
+ if {[my Bar]} { next } else { error forbidden }
+ }
+ filter boo
+ }
+ set log {}
+ list [Aobject outerfoo] $log
+} -cleanup {
+ Aclass destroy
+} -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}}
+
+test oo-13.1 {OO: changing an object's class} {
+ oo::class create Aclass
+ oo::define Aclass {method bar {} {lappend ::result "in A [self object]"}}
+ oo::class create Bclass
+ oo::define Bclass {method bar {} {lappend ::result "in B [self object]"}}
+ set result [Aclass create foo]
+ foo bar
+ oo::objdefine foo class Bclass
+ foo bar
+ Aclass destroy
+ lappend result [info command foo]
+ Bclass destroy
+ return $result
+} {::foo {in A ::foo} {in B ::foo} foo}
+test oo-13.2 {OO: changing an object's class} -body {
+ oo::object create foo
+ oo::objdefine foo class oo::class
+} -cleanup {
+ foo destroy
+} -returnCodes 1 -result {may not change a non-class object into a class object}
+test oo-13.3 {OO: changing an object's class} -body {
+ oo::class create foo
+ oo::objdefine foo class oo::object
+} -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} {
+ oo::class create Aclass
+ oo::define Aclass method bar {} {lappend ::result "[self object] in bar"}
+ oo::class create Bclass
+ oo::define Bclass method boo {} {lappend ::result "[self object] in boo"}
+ oo::objdefine [Aclass create fooTest] mixin Bclass
+ oo::objdefine [Aclass create fooTest2] mixin Bclass
+ set result [list [catch {fooTest ?} msg] $msg]
+ fooTest bar
+ fooTest boo
+ fooTest2 bar
+ fooTest2 boo
+ oo::objdefine fooTest2 mixin
+ lappend result [Bclass destroy] [info command fooTest*] [Aclass destroy]
+} {1 {unknown method "?": must be bar, boo or destroy} {::fooTest in bar} {::fooTest in boo} {::fooTest2 in bar} {::fooTest2 in boo} {} fooTest2 {}}
+test oo-14.2 {OO: mixins} {
+ oo::class create Aclass {
+ method bar {} {return "[self object] in bar"}
+ }
+ oo::class create Bclass {
+ method boo {} {return "[self object] in boo"}
+ }
+ oo::define Aclass mixin Bclass
+ Aclass create fooTest
+ set result [list [catch {fooTest ?} msg] $msg]
+ lappend result [catch {fooTest bar} msg] $msg
+ lappend result [catch {fooTest boo} msg] $msg
+ lappend result [Bclass destroy] [info commands Aclass]
+} {1 {unknown method "?": must be bar, boo or destroy} 0 {::fooTest in bar} 0 {::fooTest in boo} {} {}}
+test oo-14.3 {OO and mixins and filters - advanced case} -setup {
+ oo::class create mix
+ oo::class create c {
+ mixin mix
+ }
+ c create i
+} -body {
+ oo::define mix {
+ method foo {} {return >>[next]<<}
+ filter foo
+ }
+ oo::objdefine i method bar {} {return foobar}
+ i bar
+} -cleanup {
+ mix destroy
+ if {[info object isa object i]} {
+ error "mixin deletion failed to destroy dependent instance"
+ }
+} -result >>foobar<<
+test oo-14.4 {OO: mixin error case} -setup {
+ oo::class create c
+} -body {
+ oo::define c mixin c
+} -returnCodes error -cleanup {
+ c destroy
+} -result {may not mix a class into itself}
+test oo-14.5 {OO and mixins and filters - advanced case} -setup {
+ oo::class create mix
+ oo::class create c {
+ mixin mix
+ }
+ c create i
+} -body {
+ oo::define mix {
+ method foo {} {return >>[next]<<}
+ filter foo
+ }
+ oo::objdefine i method bar {} {return foobar}
+ i bar
+} -cleanup {
+ c destroy
+ mix destroy
+} -result >>foobar<<
+test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create A {
+ superclass master
+ method egg {} {
+ return chicken
+ }
+ }
+ oo::class create B {
+ superclass master
+ mixin A
+ method bar {} {
+ # mixin from A
+ my egg
+ }
+ }
+ oo::class create C {
+ superclass master
+ mixin B
+ method foo {} {
+ # mixin from B
+ my bar
+ }
+ }
+ [C new] foo
+} -result chicken
+test oo-14.7 {OO and filters from mixins of mixins} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create A {
+ superclass master
+ method egg {} {
+ return chicken
+ }
+ filter f
+ method f args {
+ set m [lindex [self target] 1]
+ return "($m) [next {*}$args] ($m)"
+ }
+ }
+ oo::class create B {
+ superclass master
+ mixin A
+ filter f
+ method bar {} {
+ # mixin from A
+ my egg
+ }
+ }
+ oo::class create C {
+ superclass master
+ mixin B
+ filter f
+ method foo {} {
+ # mixin from B
+ my bar
+ }
+ }
+ [C new] foo
+} -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)}
+test oo-14.8 {OO: class mixin order - Bug 1998221} -setup {
+ set ::result {}
+ oo::class create master {
+ method test {} {}
+ }
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create mix {
+ superclass master
+ method test {} {lappend ::result mix; next; return $::result}
+ }
+ oo::class create cls {
+ superclass master
+ mixin mix
+ method test {} {lappend ::result cls; next; return $::result}
+ }
+ [cls new] test
+} -result {mix cls}
+
+test oo-15.1 {OO: object cloning} {
+ oo::class create Aclass
+ oo::define Aclass method test {} {lappend ::result [self object]->test}
+ Aclass create Ainstance
+ set result {}
+ Ainstance test
+ oo::copy Ainstance Binstance
+ Binstance test
+ Ainstance test
+ Ainstance destroy
+ namespace eval foo {
+ oo::copy Binstance Cinstance
+ Cinstance test
+ }
+ Aclass destroy
+ namespace delete foo
+ lappend result [info commands Binstance]
+} {::Ainstance->test ::Binstance->test ::Ainstance->test ::foo::Cinstance->test {}}
+test oo-15.2 {OO: object cloning} {
+ oo::object create foo
+ oo::objdefine foo {
+ method m x {lappend ::result [self object] >$x<}
+ forward f ::lappend ::result fwd
+ }
+ set result {}
+ foo m 1
+ foo f 2
+ lappend result [oo::copy foo bar]
+ foo m 3
+ foo f 4
+ bar m 5
+ bar f 6
+ lappend result [foo destroy]
+ bar m 7
+ bar f 8
+ lappend result [bar destroy]
+} {::foo >1< fwd 2 ::bar ::foo >3< fwd 4 ::bar >5< fwd 6 {} ::bar >7< fwd 8 {}}
+catch {foo destroy}
+catch {bar destroy}
+test oo-15.3 {OO: class cloning} {
+ oo::class create foo {
+ method testme {} {lappend ::result [self class]->[self object]}
+ }
+ set result {}
+ foo create baseline
+ baseline testme
+ oo::copy foo bar
+ baseline testme
+ bar create tester
+ tester testme
+ foo destroy
+ tester testme
+ bar destroy
+ return $result
+} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester}
+
+test oo-16.1 {OO: object introspection} -body {
+ info object
+} -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\""
+test oo-16.2 {OO: object introspection} -body {
+ info object class NOTANOBJECT
+} -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 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
+} -body {
+ list [list [info object class oo::object] \
+ [info object class oo::class] \
+ [info object class meta] \
+ [info object class instance1] \
+ [info object class instance2]] \
+ [list [info object isa class oo::object] \
+ [info object isa class meta] \
+ [info object isa class instance1] \
+ [info object isa class instance2]] \
+ [list [info object isa metaclass oo::object] \
+ [info object isa metaclass oo::class] \
+ [info object isa metaclass meta] \
+ [info object isa metaclass instance1] \
+ [info object isa metaclass instance2]] \
+ [list [info object isa object oo::object] \
+ [info object isa object oo::class] \
+ [info object isa object meta] \
+ [info object isa object instance1] \
+ [info object isa object instance2] \
+ [info object isa object oo::define] \
+ [info object isa object NOTANOBJECT]]
+} -cleanup {
+ meta destroy
+} -result {{::oo::class ::oo::class ::oo::class ::meta ::instance1} {1 1 1 0} {0 1 1 0 0} {1 1 1 1 1 0 0}}
+test oo-16.5 {OO: object introspection} {info object methods oo::object} {}
+test oo-16.6 {OO: object introspection} {
+ oo::object create foo
+ set result [list [info object methods foo]]
+ oo::objdefine foo method bar {} {...}
+ lappend result [info object methods foo] [foo destroy]
+} {{} bar {}}
+test oo-16.7 {OO: object introspection} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo method bar {a {b c} args} {the body}
+ set result [info object methods foo]
+ lappend result [info object methodtype foo bar] \
+ [info object definition foo bar]
+} -cleanup {
+ foo destroy
+} -result {bar method {{a {b c} args} {the body}}}
+test oo-16.8 {OO: object introspection} {
+ oo::object create foo
+ oo::class create bar
+ oo::objdefine foo mixin bar
+ set result [list [info object mixins foo] \
+ [info object isa mixin foo bar] \
+ [info object isa mixin foo oo::class]]
+ foo destroy
+ bar destroy
+ return $result
+} {::bar 1 0}
+test oo-16.9 {OO: object introspection} -body {
+ oo::class create Ac
+ oo::class create Bc; oo::define Bc superclass Ac
+ oo::class create Cc; oo::define Cc superclass Bc
+ oo::class create Dc; oo::define Dc mixin Cc
+ Cc create E
+ Dc create F
+ list [info object isa typeof E oo::class] \
+ [info object isa typeof E Ac] \
+ [info object isa typeof F Bc] \
+ [info object isa typeof F Cc]
+} -cleanup {
+ catch {Ac destroy}
+} -result {0 1 1 1}
+test oo-16.10 {OO: object introspection} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo export eval
+ foo eval {variable c 3 a 1 b 2 ddd 4 e}
+ lsort [info object vars foo ?]
+} -cleanup {
+ foo destroy
+} -result {a b c}
+test oo-16.11 {OO: object introspection} -setup {
+ oo::class create foo
+ foo create bar
+} -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]
+} -cleanup {
+ foo destroy
+} -result {{boo destroy spong} {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
+} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\""
+test oo-17.2 {OO: class introspection} -body {
+ info class superclass NOTANOBJECT
+} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
+test oo-17.3 {OO: class introspection} -setup {
+ oo::object create foo
+} -body {
+ info class superclass foo
+} -returnCodes 1 -cleanup {
+ foo destroy
+} -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 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 {
+ testClass create foo
+ testClass create bar
+ testClass create spong
+ lsort [info class instances testClass]
+} -cleanup {
+ testClass destroy
+} -result {::bar ::foo ::spong}
+test oo-17.6 {OO: class introspection} -setup {
+ oo::class create foo
+} -body {
+ oo::define foo method bar {a {b c} args} {the body}
+ set result [info class methods foo]
+ lappend result [info class methodtype foo bar] \
+ [info class definition foo bar]
+} -cleanup {
+ foo destroy
+} -result {bar method {{a {b c} args} {the body}}}
+test oo-17.7 {OO: class introspection} {
+ info class superclasses oo::class
+} ::oo::object
+test oo-17.8 {OO: class introspection} -setup {
+ oo::class create testClass
+ oo::class create superClass1
+ oo::class create superClass2
+} -body {
+ oo::define testClass superclass superClass1 superClass2
+ list [info class superclasses testClass] \
+ [lsort [info class subclass oo::object ::superClass?]]
+} -cleanup {
+ testClass destroy
+ superClass1 destroy
+ superClass2 destroy
+} -result {{::superClass1 ::superClass2} {::superClass1 ::superClass2}}
+test oo-17.9 {OO: class introspection} -setup {
+ oo::class create foo
+ oo::class create subfoo {superclass foo}
+} -body {
+ oo::define foo {
+ method bar {a {b c} args} {the body}
+ self {
+ method bad {} {...}
+ }
+ }
+ oo::define subfoo method boo {a {b c} args} {the body}
+ list [info class methods subfoo -all] \
+ [info class methods subfoo -all -private]
+} -cleanup {
+ foo destroy
+} -result {{bar boo destroy} {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)
+ invoked from within
+"oo::define oo::object {error foo}"}}
+test oo-18.2 {OO: define command support} {
+ list [catch {oo::define oo::object error foo} msg] $msg $errorInfo
+} {1 foo {foo
+ while executing
+"oo::define oo::object error foo"}}
+test oo-18.3 {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 object "::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 object "::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 object "::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 {
+ oo::objdefine obj method bar {} {my eval {error foo}}
+ list [catch {obj bar} msg] $msg $errorInfo
+} -cleanup {
+ obj destroy
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in "my eval" script line 1)
+ invoked from within
+"my eval {error foo}"
+ (object "::obj" method "bar" line 1)
+ invoked from within
+"obj bar"}}
+test oo-18.5 {OO: more error traces from the guts} -setup {
+ [oo::class create cls] create obj
+ set errorInfo {}
+} -body {
+ oo::define cls {
+ method eval script {next $script}
+ export eval
+ }
+ oo::objdefine obj method bar {} {my eval {error foo}}
+ set result {}
+ lappend result [catch {obj bar} msg] $msg $errorInfo
+ lappend result [catch {obj eval {error bar}} msg] $msg $errorInfo
+} -cleanup {
+ cls destroy
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in "my eval" script line 1)
+ invoked from within
+"next $script"
+ (class "::cls" method "eval" line 1)
+ invoked from within
+"my eval {error foo}"
+ (object "::obj" method "bar" line 1)
+ invoked from within
+"obj bar"} 1 bar {bar
+ while executing
+"error bar"
+ (in "::obj eval" script line 1)
+ invoked from within
+"next $script"
+ (class "::cls" method "eval" line 1)
+ invoked from within
+"obj eval {error bar}"}}
+
+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]
+ proc foo args {
+ global ns result
+ set context [uplevel 1 namespace current]
+ lappend result $args [expr {
+ $ns eq $context ? "ok" : [list $ns ne $context]
+ }] [expr {
+ "${ns}::x" eq [uplevel 1 my varname x] ? "ok" : [list ${ns}::x ne [uplevel 1 my varname x]]
+ }]
+ }
+ lappend result [inst eval set x 0]
+} -cleanup {
+ 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-20.1 {OO: variable method} -body {
+ oo::class create testClass {
+ constructor {} {
+ my variable ok
+ set ok {}
+ }
+ }
+ lsort [info object vars [testClass new]]
+} -cleanup {
+ catch {testClass destroy}
+} -result ok
+test oo-20.2 {OO: variable method} -body {
+ oo::class create testClass {
+ constructor {} {
+ my variable a b c
+ set a [set b [set c {}]]
+ }
+ }
+ lsort [info object vars [testClass new]]
+} -cleanup {
+ catch {testClass destroy}
+} -result {a b c}
+test oo-20.3 {OO: variable method} -body {
+ oo::class create testClass {
+ export varname
+ method bar {} {
+ my variable a(b)
+ }
+ }
+ testClass create foo
+ array set [foo varname a] {b c}
+ foo bar
+} -returnCodes 1 -cleanup {
+ catch {testClass destroy}
+} -result {can't define "a(b)": name refers to an element in an array}
+test oo-20.4 {OO: variable method} -body {
+ oo::class create testClass {
+ export varname
+ method bar {} {
+ my variable a(b)
+ }
+ }
+ testClass create foo
+ set [foo varname a] b
+ foo bar
+} -returnCodes 1 -cleanup {
+ catch {testClass destroy}
+} -result {can't define "a(b)": name refers to an element in an array}
+test oo-20.5 {OO: variable method} -body {
+ oo::class create testClass {
+ method bar {} {
+ my variable a::b
+ }
+ }
+ testClass create foo
+ foo bar
+} -returnCodes 1 -cleanup {
+ catch {testClass destroy}
+} -result {variable name "a::b" illegal: must not contain namespace separator}
+test oo-20.6 {OO: variable method} -setup {
+ oo::class create testClass {
+ export varname
+ self export eval
+ }
+} -body {
+ testClass eval variable a 0
+ oo::objdefine [testClass create foo] method bar {other} {
+ $other variable a
+ set a 3
+ }
+ oo::objdefine [testClass create boo] export variable
+ set [foo varname a] 1
+ set [boo varname a] 2
+ foo bar boo
+ list [testClass eval set a] [set [foo varname a]] [set [boo varname a]]
+} -cleanup {
+ testClass destroy
+} -result {0 1 3}
+test oo-20.7 {OO: variable method} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ method a {} {
+ my variable d b
+ lappend b $d
+ }
+ method e {} {
+ my variable b d
+ return [list $b $d]
+ }
+ method f {x y} {
+ my variable b d
+ set b $x
+ set d $y
+ }
+ }
+ cls create obj
+ obj f p q
+ obj a
+ obj a
+ obj e
+} -cleanup {
+ cls destroy
+} -result {{p q q} q}
+# oo-20.8 tested explicitly for functionality removed due to [Bug 1959457]
+test oo-20.9 {OO: variable method} -setup {
+ oo::object create obj
+} -body {
+ oo::objdefine obj {
+ method a {} {
+ my variable ::b
+ }
+ }
+ obj a
+} -returnCodes 1 -cleanup {
+ obj destroy
+} -result {variable name "::b" illegal: must not contain namespace separator}
+test oo-20.10 {OO: variable and varname methods refer to same things} -setup {
+ oo::object create obj
+} -body {
+ oo::objdefine obj {
+ method a {} {
+ my variable b
+ set b [self]
+ return [my varname b]
+ }
+ }
+ list [set [obj a]] [namespace tail [obj a]]
+} -cleanup {
+ obj destroy
+} -result {::obj b}
+test oo-20.11 {OO: variable mustn't crash when recursing} -body {
+ oo::class create A {
+ constructor {name} {
+ my variable np_name
+ set np_name $name
+ }
+ method copy {nm} {
+ set cpy [[info object class [self]] new $nm]
+ foreach var [info object vars [self]] {
+ my variable $var
+ set val [set $var]
+ if {[string match o_* $var]} {
+ set objs {}
+ foreach ref $val {
+ # call to "copy" crashes
+ lappend objs [$ref copy {}]
+ }
+ $cpy prop $var $objs
+ } else {
+ $cpy prop $var $val
+ }
+ }
+ return $cpy
+ }
+ method prop {name val} {
+ my variable $name
+ set $name $val
+ }
+ }
+ set o1 [A new {}]
+ set o2 [A new {}]
+ $o1 prop o_object $o2
+ $o1 copy aa
+} -cleanup {
+ catch {A destroy}
+} -match glob -result *
+test oo-20.12 {OO: variable method accept zero args (TIP 323)} -setup {
+ oo::object create foo
+} -cleanup {
+ foo destroy
+} -body {
+ oo::objdefine foo method demo {} {
+ my variable
+ }
+ 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
+} -body {
+ oo::define A method m {} {lappend ::result A}
+ oo::class create B {
+ superclass A
+ method m {} {lappend ::result B;next}
+ }
+ oo::class create C {
+ superclass A
+ method m {} {lappend ::result C;next}
+ }
+ oo::class create D {
+ superclass B C
+ method m {} {lappend ::result D;next}
+ }
+ D create o
+ oo::objdefine o method m {} {lappend ::result o;next}
+ set result {}
+ o m
+ return $result
+} -cleanup {
+ A destroy
+} -result {o D B C A}
+test oo-21.2 {OO: inheritance ordering} -setup {
+ oo::class create A
+} -body {
+ oo::define A method m {} {lappend ::result A}
+ oo::class create B {
+ superclass A
+ method m {} {lappend ::result B;next}
+ }
+ oo::class create C {
+ superclass A
+ method m {} {lappend ::result C;next}
+ }
+ oo::class create D {
+ superclass B C
+ method m {} {lappend ::result D;next}
+ }
+ oo::class create Emix {
+ superclass C
+ method m {} {lappend ::result Emix;next}
+ }
+ oo::class create Fmix {
+ superclass Emix
+ method m {} {lappend ::result Fmix;next}
+ }
+ D create o
+ oo::objdefine o {
+ method m {} {lappend ::result o;next}
+ mixin Fmix
+ }
+ set result {}
+ o m
+ return $result
+} -cleanup {
+ A destroy
+} -result {Fmix Emix o D B C A}
+test oo-21.3 {OO: inheritance ordering} -setup {
+ oo::class create A
+} -body {
+ oo::define A method m {} {lappend ::result A}
+ oo::class create B {
+ superclass A
+ method m {} {lappend ::result B;next}
+ method f {} {lappend ::result B-filt;next}
+ }
+ oo::class create C {
+ superclass A
+ method m {} {lappend ::result C;next}
+ }
+ oo::class create D {
+ superclass B C
+ method m {} {lappend ::result D;next}
+ }
+ oo::class create Emix {
+ superclass C
+ method m {} {lappend ::result Emix;next}
+ method f {} {lappend ::result Emix-filt;next}
+ }
+ oo::class create Fmix {
+ superclass Emix
+ method m {} {lappend ::result Fmix;next}
+ }
+ D create o
+ oo::objdefine o {
+ method m {} {lappend ::result o;next}
+ mixin Fmix
+ filter f
+ }
+ set result {}
+ o m
+ return $result
+} -cleanup {
+ A destroy
+} -result {Emix-filt B-filt Fmix Emix o D B C A}
+test oo-21.4 {OO: inheritance ordering} -setup {
+ oo::class create A
+} -body {
+ oo::define A method m {} {lappend ::result A}
+ oo::class create B {
+ superclass A
+ method m {} {lappend ::result B;next}
+ method f {} {lappend ::result B-filt;next}
+ method g {} {lappend ::result B-cfilt;next}
+ }
+ oo::class create C {
+ superclass A
+ method m {} {lappend ::result C;next}
+ }
+ oo::class create D {
+ superclass B C
+ method m {} {lappend ::result D;next}
+ method g {} {lappend ::result D-cfilt;next}
+ filter g
+ }
+ oo::class create Emix {
+ superclass C
+ method m {} {lappend ::result Emix;next}
+ method f {} {lappend ::result Emix-filt;next}
+ }
+ oo::class create Fmix {
+ superclass Emix
+ method m {} {lappend ::result Fmix;next}
+ }
+ D create o
+ oo::objdefine o {
+ method m {} {lappend ::result o;next}
+ mixin Fmix
+ filter f
+ }
+ set result {}
+ o m
+ return $result
+} -cleanup {
+ A destroy
+} -result {Emix-filt B-filt D-cfilt B-cfilt Fmix Emix o D B C A}
+
+test oo-22.1 {OO and info frame} -setup {
+ oo::class create c
+ c create i
+} -match glob -body {
+ oo::define c self method frame {} {
+ info frame 0
+ }
+ oo::define c {
+ method frames {} {
+ info frame 0
+ }
+ method level {} {
+ info frame
+ }
+ }
+ oo::objdefine i {
+ method frames {} {
+ list [next] [info frame 0]
+ }
+ method level {} {
+ expr {[next] - [info frame]}
+ }
+ }
+ 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}
+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 {
+ oo::class create SELF {
+ superclass oo::class
+ unexport create new
+ # Next is just a convenience
+ method method args {oo::define [self] method {*}$args}
+ method derive {name} {
+ set o [my new [list superclass [self]]]
+ oo::objdefine $o mixin $o
+ uplevel 1 [list rename $o $name]\;[list namespace which $name]
+ }
+ self mixin SELF
+ }
+ set result {}
+} -body {
+ [SELF derive foo1] method bar1 {} {return 1}
+ lappend result [foo1 bar1]
+ [foo1 derive foo2] method bar2 {} {return [my bar1],2}
+ lappend result [foo2 bar2]
+ [foo2 derive foo3] method bar3 {} {return [my bar2],3}
+ lappend result [foo3 bar3]
+ [foo3 derive foo4] method bar4 {} {return [my bar3],4}
+ lappend result [foo4 bar4]
+ foo2 method bar2 {} {return [my bar1],x}
+ lappend result [foo4 bar4]
+} -cleanup {
+ SELF destroy
+} -result {1 1,2 1,2,3 1,2,3,4 1,x,3,4}
+
+test oo-24.1 {unknown method method - Bug 1965063} -setup {
+ oo::class create cls
+} -cleanup {
+ cls destroy
+} -returnCodes error -body {
+ oo::define cls {
+ method dummy {} {}
+ method unknown args {next {*}$args}
+ }
+ [cls new] foo bar
+} -result {unknown method "foo": must be destroy, dummy or unknown}
+test oo-24.2 {unknown method method - Bug 1965063} -setup {
+ oo::class create cls
+} -cleanup {
+ cls destroy
+} -returnCodes error -body {
+ oo::define cls {
+ method dummy {} {}
+ method unknown args {next {*}$args}
+ }
+ cls create obj
+ oo::objdefine obj {
+ method dummy2 {} {}
+ method unknown args {next {*}$args}
+ }
+ obj foo bar
+} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
+
+# Probably need a better set of tests, but this is quite difficult to devise
+test oo-25.1 {call chain caching} -setup {
+ oo::class create cls {
+ method ab {} {return ok}
+ }
+ set result {}
+} -cleanup {
+ cls destroy
+} -body {
+ cls create foo
+ cls create bar
+ set m1 ab
+ set m2 a; append m2 b ;# different object!
+ lappend result [foo $m1] [foo $m1] [bar $m1] [foo $m1]
+ lappend result [foo $m2] [bar $m2]
+ oo::objdefine foo method ab {} {return good}
+ lappend result [foo $m1] [bar $m2]
+} -result {ok ok ok ok ok ok good ok}
+test oo-25.2 {call chain caching - Bug #2120903} -setup {
+ set c [oo::class create MyClass]
+ set o [$c new]
+} -body {
+ oo::define MyClass {
+ method name {} {return ok}
+ method isa o {MyClass name $o}
+ self method name o {$o name}
+ }
+ list [$o name] [$c name $o] [$o isa $o]
+} -cleanup {
+ $c destroy
+} -result {ok ok ok}
+
+test oo-26.1 {Bug 2037727} -setup {
+ proc succeed args {}
+ oo::object create example
+} -body {
+ oo::objdefine example method foo {} {succeed}
+ example foo
+ proc succeed {} {return succeed}
+ example foo
+} -cleanup {
+ example destroy
+ rename succeed {}
+} -result succeed
+test oo-26.2 {Bug 2037727} -setup {
+ oo::class create example {
+ method localProc {args body} {proc called $args $body}
+ method run {} { called }
+ }
+ example create i1
+ example create i2
+} -body {
+ i1 localProc args {}
+ i2 localProc args {return nonempty}
+ list [i1 run] [i2 run]
+} -cleanup {
+ example destroy
+} -result {{} nonempty}
+test oo-26.3 {Bug 2037727} -setup {
+ oo::class create example {
+ method subProc {args body} {
+ namespace eval subns [list proc called $args $body]
+ }
+ method run {} { subns::called }
+ }
+ example create i1
+ example create i2
+} -body {
+ i1 subProc args {}
+ i2 subProc args {return nonempty}
+ list [i1 run] [i2 run]
+} -cleanup {
+ example destroy
+} -result {{} nonempty}
+
+test oo-27.1 {variables declaration - class introspection} -setup {
+ oo::class create foo
+} -cleanup {
+ foo destroy
+} -body {
+ oo::define foo variable a b c
+ info class variables foo
+} -result {a b c}
+test oo-27.2 {variables declaration - object introspection} -setup {
+ oo::object create foo
+} -cleanup {
+ foo destroy
+} -body {
+ oo::objdefine foo variable a b c
+ info object variables foo
+} -result {a b c}
+test oo-27.3 {variables declaration - basic behaviour} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x!
+ constructor {} {set x! 1}
+ method y {} {incr x!}
+ }
+ foo create bar
+ bar y
+ bar y
+} -result 3
+test oo-27.4 {variables declaration - destructors too} -setup {
+ oo::class create master
+ set result bad!
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x!
+ constructor {} {set x! 1}
+ method y {} {incr x!}
+ destructor {set ::result ${x!}}
+ }
+ foo create bar
+ bar y
+ bar y
+ bar destroy
+ return $result
+} -result 3
+test oo-27.5 {variables declaration - object-bound variables} -setup {
+ oo::object create foo
+} -cleanup {
+ foo destroy
+} -body {
+ oo::objdefine foo {
+ variable x!
+ method y {} {incr x!}
+ }
+ foo y
+ foo y
+} -result 2
+test oo-27.6 {variables declaration - non-interference of levels} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x!
+ constructor {} {set x! 1}
+ method y {} {incr x!}
+ }
+ foo create bar
+ oo::objdefine bar {
+ variable y!
+ method y {} {list [next] [incr y!] [info var] [info local]}
+ export eval
+ }
+ bar y
+ list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}]
+} -result {{3 2 y! {}} {x! y!} {x! y!}}
+test oo-27.7 {variables declaration - one underlying variable space} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable x!
+ constructor {} {set x! 1}
+ method y {} {incr x!}
+ }
+ oo::class create foo2 {
+ superclass foo
+ variable y!
+ constructor {} {set y! 42; next}
+ method x {} {incr y! -1}
+ }
+ foo2 create bar
+ oo::objdefine bar {
+ variable x! y!
+ method z {} {list ${x!} ${y!}}
+ }
+ bar y
+ bar x
+ list [bar y] [bar x] [bar z]
+} -result {3 40 {3 40}}
+test oo-27.8 {variables declaration - error cases - ns separators} -body {
+ oo::define oo::object variable bad::var
+} -returnCodes error -result {invalid declared variable name "bad::var": must not contain namespace separators}
+test oo-27.9 {variables declaration - error cases - arrays} -body {
+ oo::define oo::object variable bad(var)
+} -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element}
+test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable clsvar
+ constructor {} {
+ set clsvar 0
+ }
+ method step {} {
+ incr clsvar
+ return
+ }
+ method value {} {
+ return $clsvar
+ }
+ }
+ foo create inst1
+ inst1 step
+ foo create inst2
+ inst2 step
+ inst1 step
+ inst2 step
+ inst1 step
+ list [inst1 value] [inst2 value]
+} -result {3 2}
+test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup {
+ oo::class create master
+} -cleanup {
+ master destroy
+} -body {
+ oo::class create foo {
+ superclass master
+ variable clsvar
+ constructor {} {
+ set clsvar 0
+ }
+ method step {} {
+ incr clsvar
+ return
+ }
+ method value {} {
+ return $clsvar
+ }
+ }
+ foo create inst1
+ oo::objdefine inst1 {
+ variable clsvar
+ method reinit {} {
+ set clsvar 0
+ }
+ }
+ foo create inst2
+ oo::objdefine inst2 {
+ variable clsvar
+ method reinit {} {
+ set clsvar 0
+ }
+ }
+ inst1 step
+ inst2 step
+ inst1 reinit
+ inst2 reinit
+ inst1 step
+ inst2 step
+ inst1 step
+ inst2 step
+ 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}}
+
+# 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 {}}
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-11-24 22:05:21 (GMT)