summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/info.test10
-rw-r--r--tests/interp.test15
-rw-r--r--tests/oo.test1769
3 files changed, 1782 insertions, 12 deletions
diff --git a/tests/info.test b/tests/info.test
index a6fa48d..b6b708c 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: info.test,v 1.47 2007/12/13 15:26:06 dgp Exp $
+# RCS: @(#) $Id: info.test,v 1.48 2008/05/31 11:42:20 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -675,16 +675,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
} -result {wrong # args: should be "info subcommand ?argument ...?"}
test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
info gorp
-} -result {unknown or ambiguous subcommand "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.3 {miscellaneous error conditions} -returnCodes error -body {
info c
-} -result {unknown or ambiguous subcommand "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.4 {miscellaneous error conditions} -returnCodes error -body {
info l
-} -result {unknown or ambiguous subcommand "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
info s
-} -result {unknown or ambiguous subcommand "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
##
# ### ### ### ######### ######### #########
diff --git a/tests/interp.test b/tests/interp.test
index 76d642b..2bbd7a3 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: interp.test,v 1.54 2008/03/02 19:12:41 msofer Exp $
+# RCS: @(#) $Id: interp.test,v 1.55 2008/05/31 11:42:20 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
@@ -2360,22 +2360,23 @@ test interp-28.1 {getting fooled by slave's namespace ?} {
set r
} {}
-test interp-28.2 {master's nsName cache should not cross} {
+test interp-28.2 {master's nsName cache should not cross} -setup {
set i [interp create]
- set res [$i eval {
+} -body {
+ $i eval {
set x {namespace children ::}
set y [list namespace children ::]
- namespace delete [{*}$y]
+ namespace delete {*}[{*}$y]
set j [interp create]
$j eval {namespace delete {*}[namespace children ::]}
namespace eval foo {}
set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]]
interp delete $j
set res
- }]
+ }
+} -cleanup {
interp delete $i
- set res
-} {::foo ::foo {} {}}
+} -result {::foo ::foo {} {}}
# Part 29: recursion limit
# 29.1.* Argument checking
diff --git a/tests/oo.test b/tests/oo.test
new file mode 100644
index 0000000..087e786
--- /dev/null
+++ b/tests/oo.test
@@ -0,0 +1,1769 @@
+# 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-2008 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.4 2008/05/31 11:42:20 dkf Exp $
+
+package require TclOO 0.4 ;# Must match value in configure.in
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ 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}]
+ }
+}
+
+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
+ }
+ interp delete t
+} {}
+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 ::
+ }
+} {}
+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-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-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
+ }
+} -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-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
+ initInterpreter 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
+ initInterpreter 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-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-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-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 {
+ 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} {
+ oo::class create foo {
+ method bar {} {lappend ::result [next] foo}
+ }
+ oo::class create foo2 {
+ superclass foo
+ method bar {} {lappend ::result [next] foo2}
+ }
+ set o [foo2 new]
+ set ::result ""
+ catch {$o bar}
+ foo destroy
+ return $result
+} {{} foo {{} foo} foo2}
+
+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}
+# 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-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 ?argument ...?\""
+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 class, definition, filters, forward, isa, methods, mixins, 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 definition foo bar]
+} -cleanup {
+ foo destroy
+} -result {bar {{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-17.1 {OO: class introspection} -body {
+ info class
+} -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?argument ...?\""
+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 constructor, definition, destructor, filters, forward, instances, methods, mixins, subclasses, or superclasses}
+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 definition foo bar]
+} -cleanup {
+ foo destroy
+} -result {bar {{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-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.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 {}
+} -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-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-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
+} -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 proc line 2 cmd {info frame 0} method frames class ::c level 0} {type proc line 2 cmd {info frame 0} method frames object ::i level 0}} ::c}
+
+# 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}
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-07-19 16:32:05 (GMT)