diff options
Diffstat (limited to 'tests/oo.test')
| -rw-r--r-- | tests/oo.test | 3383 |
1 files changed, 0 insertions, 3383 deletions
diff --git a/tests/oo.test b/tests/oo.test deleted file mode 100644 index 49fe150..0000000 --- a/tests/oo.test +++ /dev/null @@ -1,3383 +0,0 @@ -# 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-2012 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 TclOO 1.0 -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.5.1 {basic test of OO functionality} -setup { - oo::object create aninstance -} -returnCodes error -body { - aninstance -} -cleanup { - rename aninstance {} -} -result {wrong # args: should be "aninstance method ?arg ...?"} -test oo-1.6 {basic test of OO functionality} -setup { - oo::object create aninstance -} -body { - 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-2.7 {construction, method calls and ensembles - Bug 3514761} -setup { - namespace eval k {} -} -body { - namespace eval k { - oo::class create s { - constructor {j} { - # nothing - } - } - namespace export s - namespace ensemble create - } - k s create X -} -returnCodes error -cleanup { - namespace delete k -} -result {wrong # args: should be "k s create X j"} -test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup { - namespace eval k {} -} -body { - namespace eval k { - oo::class create s { - constructor {j} { - # nothing - } - } - oo::class create t { - superclass s - constructor args { - k next {*}$args - } - } - interp alias {} ::k::next {} ::oo::Helpers::next - namespace export t next - namespace ensemble create - } - k t create X -} -returnCodes error -cleanup { - namespace delete k -} -result {wrong # args: should be "k next j"} - -test oo-3.1 {basic test of OO functionality: destructor} -setup { - # This is a bit complex because it needs to run in a sub-interp as we're - # modifying the root object class's constructor - 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-6.8 {Bug 3400658: forwarding and wrongargs rewriting} -setup { - oo::class create fooClass -} -body { - oo::define fooClass { - forward test my handler - method handler {a b c} {} - } - fooClass create ::foo - foo test -} -returnCodes error -cleanup { - fooClass destroy -} -result {wrong # args: should be "foo test a b c"} -test oo-6.9 {Bug 3400658: forwarding and wrongargs rewriting} -setup { - oo::class create fooClass -} -body { - oo::define fooClass { - forward test my handler - method handler {a b c} {list $a,$b,$c} - } - fooClass create ::foo - foo test 1 2 3 -} -cleanup { - fooClass destroy -} -result 1,2,3 -test oo-6.10 {Bug 3400658: forwarding and wrongargs rewriting} -setup { - oo::class create fooClass -} -body { - oo::define fooClass { - forward test my handler - method handler {a b c} {list $a,$b,$c} - } - fooClass create ::foo - foo test 1 2 -} -returnCodes error -cleanup { - fooClass destroy -} -result {wrong # args: should be "foo test a b c"} -test oo-6.11 {Bug 3400658: forwarding and wrongargs rewriting} -setup { - oo::object create foo -} -body { - oo::objdefine foo { - forward test my handler - method handler {a b c} {} - } - foo test -} -returnCodes error -cleanup { - foo destroy -} -result {wrong # args: should be "foo test a b c"} -test oo-6.12 {Bug 3400658: forwarding and wrongargs rewriting} -setup { - oo::object create foo -} -body { - oo::objdefine foo { - forward test my handler - method handler {a b c} {list $a,$b,$c} - } - foo test 1 2 3 -} -cleanup { - foo destroy -} -result 1,2,3 -test oo-6.13 {Bug 3400658: forwarding and wrongargs rewriting} -setup { - oo::object create foo -} -body { - oo::objdefine foo { - forward test my handler - method handler {a b c} {list $a,$b,$c} - } - foo test 1 2 -} -returnCodes error -cleanup { - foo destroy -} -result {wrong # args: should be "foo test a b c"} -test oo-6.14 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup { - oo::class create fooClass -} -body { - oo::define fooClass { - forward test my handler1 p - forward handler1 my handler q - method handler {a b c} {} - } - fooClass create ::foo - foo test -} -returnCodes error -cleanup { - fooClass destroy -} -result {wrong # args: should be "foo test c"} -test oo-6.15 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup { - oo::class create fooClass -} -body { - oo::define fooClass { - forward test my handler1 p - forward handler1 my handler q - method handler {a b c} {list $a,$b,$c} - } - fooClass create ::foo - foo test 1 -} -cleanup { - fooClass destroy -} -result q,p,1 -test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setup { - oo::class create fooClass -} -body { - oo::define fooClass { - forward test handler1 foo bar - forward handler2 my handler x - method handler {a b c d} {list $a,$b,$c,$d} - export eval - } - fooClass create ::foo - foo eval { - interp alias {} [namespace current]::handler1 \ - {} [namespace current]::my handler2 - } - foo test 1 2 3 -} -returnCodes error -cleanup { - fooClass destroy -} -result {wrong # args: should be "foo test d"} -test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -setup { - oo::class create fooClass -} -body { - oo::define fooClass { - forward test handler1 foo bar boo - forward handler2 my handler - method handler {a b c d} {list $a,$b,$c,$d} - export eval - } - fooClass create ::foo - foo eval { - namespace ensemble create \ - -command [namespace current]::handler1 -parameters {p q} \ - -map [list boo [list [namespace current]::my handler2]] - } - foo test 1 2 3 -} -returnCodes error -cleanup { - fooClass destroy -} -result {wrong # args: should be "foo test c d"} -test oo-6.18 {Bug 3408830: more forwarding cases} -setup { - oo::class create fooClass -} -body { - oo::define fooClass { - forward len string length - } - [fooClass create foo] len a b -} -returnCodes error -cleanup { - fooClass destroy -} -result {wrong # args: should be "::foo len string"} - -test oo-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-15.4 {OO: object cloning - Bug 3474460} -setup { - oo::class create ArbitraryClass -} -body { - ArbitraryClass create foo - oo::objdefine foo variable a b c - oo::copy foo bar - info object variable bar -} -cleanup { - ArbitraryClass destroy -} -result {a b c} -test oo-15.5 {OO: class cloning - Bug 3474460} -setup { - oo::class create ArbitraryClass -} -body { - oo::class create Foo { - superclass ArbitraryClass - variable a b c - } - oo::copy Foo Bar - info class variable Bar -} -cleanup { - ArbitraryClass destroy -} -result {a b c} -test oo-15.6 {OO: object cloning copies namespace contents} -setup { - oo::class create ArbitraryClass {export eval} -} -body { - ArbitraryClass create a - a eval {proc foo x { - variable y - return [string repeat $x [incr y]] - }} - set result [list [a eval {foo 2}] [a eval {foo 3}]] - oo::copy a b - a eval {rename foo bar} - lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}] -} -cleanup { - ArbitraryClass destroy -} -result {2 33 222 3333 444} -test oo-15.7 {OO: classes can be cloned anonymously} -setup { - oo::class create ArbitraryClassA - oo::class create ArbitraryClassB {superclass ArbitraryClassA} -} -body { - info object isa class [oo::copy ArbitraryClassB] -} -cleanup { - ArbitraryClassA destroy -} -result 1 -test oo-15.8 {OO: intercept object cloning} -setup { - oo::class create Foo - set result {} -} -body { - oo::define Foo { - constructor {msg} { - variable v $msg - } - method <cloned> {from} { - next $from - lappend ::result cloned $from [self] - } - method check {} { - variable v - lappend ::result check [self] $v - } - } - Foo create foo ok - oo::copy foo bar - foo check - bar check -} -cleanup { - Foo destroy -} -result {cloned ::foo ::bar check ::foo ok check ::bar ok} -test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { - oo::class create Foo -} -body { - oo::define Foo { - method <cloned> {a b} {} - } - interp alias {} Bar {} oo::copy [Foo create foo] - Bar bar -} -returnCodes error -cleanup { - Foo destroy -} -result {wrong # args: should be "::bar <cloned> a b"} - -test oo-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 [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]] -} -cleanup { - foo destroy -} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}} -test oo-16.12 {OO: object introspection} -setup { - oo::object create foo -} -cleanup { - rename foo {} -} -body { - oo::objdefine foo unexport {*}[info object methods foo -all] - info object methods foo -all -} -result {} -test oo-16.13 {OO: object introspection} -setup { - oo::object create foo -} -cleanup { - rename foo {} -} -body { - oo::objdefine foo method Bar {} {return "ok in foo"} - [info object namespace foo]::my Bar -} -result "ok in foo" - -test oo-17.1 {OO: class introspection} -body { - info class -} -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 [lsort [info class methods subfoo -all]] \ - [lsort [info class methods subfoo -all -private]] -} -cleanup { - foo destroy -} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}} -test oo-17.10 {OO: class introspection} -setup { - oo::class create foo -} -cleanup { - rename foo {} -} -body { - oo::define foo unexport {*}[info class methods foo -all] - info class methods foo -all -} -result {} - -test oo-18.1 {OO: define command support} { - list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo -} {1 foo {foo - while executing -"error foo" - (in definition script for class "::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 class "::foo" line 1) - invoked from within -"oo::class create foo {error bar}"}} -test oo-18.3a {OO: define command support} { - list [catch {oo::class create foo { - error bar -}} msg] $msg $errorInfo -} {1 bar {bar - while executing -"error bar" - (in definition script for class "::foo" line 2) - invoked from within -"oo::class create foo { - error bar -}"}} -test oo-18.3b {OO: define command support} { - list [catch {oo::class create foo { - eval eval error bar -}} msg] $msg $errorInfo -} {1 bar {bar - while executing -"error bar" - ("eval" body line 1) - invoked from within -"eval error bar" - ("eval" body line 1) - invoked from within -"eval eval error bar" - (in definition script for class "::foo" line 2) - invoked from within -"oo::class create foo { - eval eval error bar -}"}} -test oo-18.4 {OO: more error traces from the guts} -setup { - oo::object create obj -} -body { - 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-18.6 {class construction reference management and errors} -setup { - oo::class create super_abc -} -body { - catch { -oo::class create abc { - superclass super_abc - ::rename abc ::def - ::error foo -} - } msg opt - dict get $opt -errorinfo -} -cleanup { - super_abc destroy -} -result {foo - while executing -"::error foo" - (in definition script for class "::def" line 4) - invoked from within -"oo::class create abc { - superclass super_abc - ::rename abc ::def - ::error foo -}"} -test oo-18.7 {OO: objdefine command support} -setup { - oo::object create ::inst -} -body { - list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo -} -cleanup { - catch {::inst destroy} - catch {::INST destroy} -} -result {1 foo {foo - while executing -"error foo" - (in definition script for object "::INST" line 1) - invoked from within -"oo::objdefine inst {rename ::inst ::INST;error foo}"}} -test oo-18.8 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} -} -body { - catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt - dict get $opt -errorinfo -} -cleanup { - master destroy -} -result {foobar - while executing -"error foobar" - (in definition script for class object "::bar" line 1) - invoked from within -"self {error foobar}" - (in definition script for class "::bar" line 1) - invoked from within -"oo::define foo {rename ::foo ::bar; self {error foobar}}"} -test oo-18.9 {OO: define/self command support} -setup { - oo::class create master - set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { - superclass master - }] -} -body { - catch {oo::define $c {error err}} msg opt - dict get $opt -errorinfo -} -cleanup { - master destroy -} -result {err - while executing -"error err" - (in definition script for class "::now_this_is_a_very_very_long..." line 1) - invoked from within -"oo::define $c {error err}"} -test oo-18.10 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} -} -body { - catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt - dict get $opt -errorinfo -} -cleanup { - master destroy -} -result {foobar - while executing -"error foobar" - (in definition script for class object "::foo" line 1) - invoked from within -"self {rename ::foo {}; error foobar}" - (in definition script for class "::foo" line 1) - invoked from within -"oo::define foo {self {rename ::foo {}; error foobar}}"} -test oo-18.11 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} -} -body { - catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt - dict get $opt -errorinfo -} -cleanup { - master destroy -} -result {this command cannot be called when the object has been deleted - while executing -"self {error foobar}" - (in definition script for class "::foo" line 1) - invoked from within -"oo::define foo {rename ::foo {}; self {error foobar}}"} - -test oo-19.1 {OO: varname method} -setup { - oo::object create inst - oo::objdefine inst export eval - set result {} - inst eval { variable x } -} -body { - inst eval {trace add variable x write foo} - set ns [inst eval namespace current] - 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-19.3 {OO: varname method and variable decl: Bug 3603695} -setup { - oo::class create testClass { - variable foo - export varname - constructor {} { - variable foo x - } - method bar {obj} { - my varname foo - $obj varname foo - } - } -} -body { - testClass create A - testClass create B - lsearch [list [A varname foo] [B varname foo]] [B bar A] -} -cleanup { - testClass destroy -} -result 0 - -test oo-20.1 {OO: variable method} -body { - oo::class create testClass { - 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 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c} -test oo-22.2 {OO and info frame: Bug 3001438} -setup { - oo::class create c -} -body { - oo::define c method test {{x 1}} { - if {$x} {my test 0} - lsort {q w e r t y u i o p}; # Overwrite the Tcl stack - info frame 0 - } - [c new] test -} -match glob -cleanup { - c destroy -} -result {* cmd {info frame 0} method test class ::c level 0} - -# Prove that the issue in [Bug 1865054] isn't an issue any more -test oo-23.1 {Self-like derivation; complex case!} -setup { - 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} -test oo-24.3 {unknown method method - absent method name} -setup { - set o [oo::object new] -} -cleanup { - $o destroy -} -body { - oo::objdefine $o method unknown args { - return "unknown: >>$args<<" - } - list [$o] [$o foobar] [$o foo bar] -} -result {{unknown: >><<} {unknown: >>foobar<<} {unknown: >>foo bar<<}} - -# Probably need a better set of tests, but this is quite difficult to devise -test oo-25.1 {call chain caching} -setup { - 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}} -test oo-27.14 {variables declaration - multiple use} -setup { - oo::class create master -} -cleanup { - master destroy -} -body { - oo::class create foo { - superclass master - variable x - variable y - method boo {} { - return [incr x],[incr y] - } - } - foo create bar - list [bar boo] [bar boo] -} -result {1,1 2,2} -test oo-27.15 {variables declaration - multiple use} -setup { - oo::class create master -} -cleanup { - master destroy -} -body { - oo::class create foo { - superclass master - variable - variable x y - method boo {} { - return [incr x],[incr y] - } - } - foo create bar - list [bar boo] [bar boo] -} -result {1,1 2,2} -test oo-27.16 {variables declaration - multiple use} -setup { - oo::class create master -} -cleanup { - master destroy -} -body { - oo::class create foo { - superclass master - variable x - variable -clear - variable y - method boo {} { - return [incr x],[incr y] - } - } - foo create bar - list [bar boo] [bar boo] -} -result {1,1 1,2} -test oo-27.17 {variables declaration - multiple use} -setup { - oo::class create master -} -cleanup { - master destroy -} -body { - oo::class create foo { - superclass master - variable x - variable -set y - method boo {} { - return [incr x],[incr y] - } - } - foo create bar - list [bar boo] [bar boo] -} -result {1,1 1,2} -test oo-27.18 {variables declaration - multiple use} -setup { - oo::class create master -} -cleanup { - master destroy -} -body { - oo::class create foo { - superclass master - variable x - variable -? y - method boo {} { - return [incr x],[incr y] - } - } - foo create bar - list [bar boo] [bar boo] -} -returnCodes error -match glob -result {unknown method "-?": must be *} -test oo-27.19 {variables declaration and [info vars]: Bug 2712377} -setup { - oo::class create Foo - set result {} -} -body { - # This is really a test of problems to do with Tcl's introspection when a - # variable resolver is present... - oo::define Foo { - variable foo bar - method setvars {f b} { - set foo $f - set bar $b - } - method dump1 {} { - lappend ::result <1> - foreach v [lsort [info vars *]] { - lappend ::result $v=[set $v] - } - lappend ::result [info locals] [info locals *] - } - method dump2 {} { - lappend ::result <2> - foreach v [lsort [info vars *]] { - lappend ::result $v=[set $v] - } - lappend ::result | foo=$foo [info locals] [info locals *] - } - } - Foo create stuff - stuff setvars what ever - stuff dump1 - stuff dump2 - return $result -} -cleanup { - Foo destroy -} -result {<1> bar=ever foo=what v v <2> bar=ever foo=what | foo=what v v} -test oo-27.20 {variables declaration and [info vars]: Bug 2712377} -setup { - oo::class create Foo - set result {} -} -body { - # This is really a test of problems to do with Tcl's introspection when a - # variable resolver is present... - oo::define Foo { - variable foo bar - method setvars {f b} { - set foo $f - set bar $b - } - method dump1 {} { - lappend ::result <1> - foreach v [lsort [info vars *o]] { - lappend ::result $v=[set $v] - } - lappend ::result [info locals] [info locals *] - } - method dump2 {} { - lappend ::result <2> - foreach v [lsort [info vars *o]] { - lappend ::result $v=[set $v] - } - lappend ::result | foo=$foo [info locals] [info locals *] - } - } - Foo create stuff - stuff setvars what ever - stuff dump1 - stuff dump2 - return $result -} -cleanup { - Foo destroy -} -result {<1> foo=what v v <2> foo=what | foo=what v v} -test oo-27.21 {variables declaration uniqueifies: Bug 3396896} -setup { - oo::class create Foo -} -body { - oo::define Foo variable v v v t t v t - info class variable Foo -} -cleanup { - Foo destroy -} -result {v t} -test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { - oo::object create foo -} -body { - oo::objdefine foo variable v v v t t v t - info object variable foo -} -cleanup { - foo destroy -} -result {v t} - -# A feature that's not supported because the mechanism may change without -# warning, but is supposed to work... -test oo-28.1 {scripted extensions to oo::define} -setup { - interp create foo - foo eval {oo::class create cls {export eval}} -} -cleanup { - interp delete foo -} -body { - foo eval { - proc oo::define::privateMethod {name arguments body} { - uplevel 1 [list method $name $arguments $body] - uplevel 1 [list unexport $name] - } - oo::define cls privateMethod m {x y} {return $x,$y} - cls create obj - list [catch {obj m 1 2}] [obj eval my m 3 4] - } -} -result {1 3,4} - -test oo-29.1 {self class with object-defined methods} -setup { - oo::object create obj -} -body { - oo::objdefine obj method demo {} { - self class - } - obj demo -} -returnCodes error -cleanup { - obj destroy -} -result {method not defined by a class} - -test oo-30.1 {Bug 2903011: deleting an object in a constructor} -setup { - oo::class create cls -} -body { - oo::define cls {constructor {} {[self] destroy}} - cls new -} -returnCodes error -cleanup { - cls destroy -} -result {object deleted in constructor} -test oo-30.2 {Bug 2903011: deleting an object in a constructor} -setup { - oo::class create cls -} -body { - oo::define cls {constructor {} {my destroy}} - cls new -} -returnCodes error -cleanup { - cls destroy -} -result {object deleted in constructor} - -test oo-31.1 {Bug 3111059: when objects and coroutines entangle} -setup { - oo::class create cls -} -constraints memory -body { - oo::define cls { - method justyield {} { - yield - } - constructor {} { - coroutine coro my justyield - } - } - list [leaktest {[cls new] destroy}] [info class instances cls] -} -cleanup { - cls destroy -} -result {0 {}} -test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup { - oo::class create cls -} -constraints memory -body { - oo::define cls { - method justyield {} { - yield - } - constructor {} { - coroutine coro my justyield - } - destructor { - rename coro {} - } - } - list [leaktest {[cls new] destroy}] [info class instances cls] -} -cleanup { - cls destroy -} -result {0 {}} - -oo::class create SampleSlot { - superclass oo::Slot - constructor {} { - variable contents {a b c} ops {} - } - method contents {} {variable contents; return $contents} - method ops {} {variable ops; return $ops} - method Get {} { - variable contents - variable ops - lappend ops [info level] Get - return $contents - } - method Set {lst} { - variable contents $lst - variable ops - lappend ops [info level] Set $lst - return - } -} - -test oo-32.1 {TIP 380: slots - class test} -setup { - SampleSlot create sampleSlot -} -body { - list [info level] [sampleSlot contents] [sampleSlot ops] -} -cleanup { - rename sampleSlot {} -} -result {0 {a b c} {}} -test oo-32.2 {TIP 380: slots - class test} -setup { - SampleSlot create sampleSlot -} -body { - list [info level] [sampleSlot -clear] \ - [sampleSlot contents] [sampleSlot ops] -} -cleanup { - rename sampleSlot {} -} -result {0 {} {} {1 Set {}}} -test oo-32.3 {TIP 380: slots - class test} -setup { - SampleSlot create sampleSlot -} -body { - list [info level] [sampleSlot -append g h i] \ - [sampleSlot contents] [sampleSlot ops] -} -cleanup { - rename sampleSlot {} -} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} -test oo-32.4 {TIP 380: slots - class test} -setup { - SampleSlot create sampleSlot -} -body { - list [info level] [sampleSlot -set d e f] \ - [sampleSlot contents] [sampleSlot ops] -} -cleanup { - rename sampleSlot {} -} -result {0 {} {d e f} {1 Set {d e f}}} -test oo-32.5 {TIP 380: slots - class test} -setup { - SampleSlot create sampleSlot -} -body { - list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \ - [sampleSlot contents] [sampleSlot ops] -} -cleanup { - rename sampleSlot {} -} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} - -test oo-33.1 {TIP 380: slots - defaulting} -setup { - set s [SampleSlot new] -} -body { - list [$s x y] [$s contents] -} -cleanup { - rename $s {} -} -result {{} {a b c x y}} -test oo-33.2 {TIP 380: slots - defaulting} -setup { - set s [SampleSlot new] -} -body { - list [$s destroy; $s unknown] [$s contents] -} -cleanup { - rename $s {} -} -result {{} {a b c destroy unknown}} -test oo-33.3 {TIP 380: slots - defaulting} -setup { - set s [SampleSlot new] -} -body { - oo::objdefine $s forward --default-operation my -set - list [$s destroy; $s unknown] [$s contents] [$s ops] -} -cleanup { - rename $s {} -} -result {{} unknown {1 Set destroy 1 Set unknown}} -test oo-33.4 {TIP 380: slots - errors} -setup { - set s [SampleSlot new] -} -body { - # Method names beginning with "-" are special to slots - $s -grill q -} -returnCodes error -cleanup { - rename $s {} -} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops} - -SampleSlot destroy - -test oo-34.1 {TIP 380: slots - presence} -setup { - set obj [oo::object new] - set result {} -} -body { - oo::define oo::object { - ::lappend ::result [::info object class filter] - ::lappend ::result [::info object class mixin] - ::lappend ::result [::info object class superclass] - ::lappend ::result [::info object class variable] - } - oo::objdefine $obj { - ::lappend ::result [::info object class filter] - ::lappend ::result [::info object class mixin] - ::lappend ::result [::info object class variable] - } - return $result -} -cleanup { - $obj destroy -} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot} -test oo-34.2 {TIP 380: slots - presence} { - lsort [info class instances oo::Slot] -} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} -proc getMethods obj { - list [lsort [info object methods $obj -all]] \ - [lsort [info object methods $obj -private]] -} -test oo-34.3 {TIP 380: slots - presence} { - getMethods oo::define::filter -} {{-append -clear -set} {Get Set}} -test oo-34.4 {TIP 380: slots - presence} { - getMethods oo::define::mixin -} {{-append -clear -set} {--default-operation Get Set}} -test oo-34.5 {TIP 380: slots - presence} { - getMethods oo::define::superclass -} {{-append -clear -set} {--default-operation Get Set}} -test oo-34.6 {TIP 380: slots - presence} { - getMethods oo::define::variable -} {{-append -clear -set} {Get Set}} -test oo-34.7 {TIP 380: slots - presence} { - getMethods oo::objdefine::filter -} {{-append -clear -set} {Get Set}} -test oo-34.8 {TIP 380: slots - presence} { - getMethods oo::objdefine::mixin -} {{-append -clear -set} {--default-operation Get Set}} -test oo-34.9 {TIP 380: slots - presence} { - getMethods oo::objdefine::variable -} {{-append -clear -set} {Get Set}} - -cleanupTests -return - -# Local Variables: -# mode: tcl -# End: |