summaryrefslogtreecommitdiffstats
path: root/tests/oo.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/oo.test')
-rw-r--r--tests/oo.test880
1 files changed, 854 insertions, 26 deletions
diff --git a/tests/oo.test b/tests/oo.test
index 60d0077..d63e931 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2,12 +2,12 @@
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
-# Copyright (c) 2006-2008 Donal K. Fellows
+# Copyright (c) 2006-2013 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
+package require TclOO 1.0.1
package require tcltest 2
if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
@@ -29,15 +29,9 @@ if {[testConstraint memory]} {
return [expr {$end - $tmp}]
}
}
-
-proc initInterpreter name {
- $name eval [list package ifneeded TclOO [package provide TclOO] \
- [package ifneeded TclOO [package provide TclOO]]]
-}
test oo-0.1 {basic test of OO's ability to clean up its initial state} {
interp create t
- initInterpreter t
t eval {
package require TclOO
}
@@ -45,11 +39,11 @@ test oo-0.1 {basic test of OO's ability to clean up its initial state} {
} {}
test oo-0.2 {basic test of OO's ability to clean up its initial state} {
set i [interp create]
- initInterpreter $i
interp eval $i {
package require TclOO
namespace delete ::
}
+ interp delete $i
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
@@ -72,7 +66,6 @@ test oo-0.5 {testing literal leak on interp delete} memory {
} 0
test oo-0.6 {cleaning the core class pair; way #1} -setup {
interp create t
- initInterpreter t
} -body {
t eval {
package require TclOO
@@ -84,7 +77,6 @@ test oo-0.6 {cleaning the core class pair; way #1} -setup {
} -result {0 {} 1 {invalid command name "object"}}
test oo-0.7 {cleaning the core class pair; way #2} -setup {
interp create t
- initInterpreter t
} -body {
t eval {
package require TclOO
@@ -106,6 +98,10 @@ test oo-0.8 {leak in variable management} -setup {
} -cleanup {
foo destroy
} -result 0
+test oo-0.9 {various types of presence of the TclOO package} {
+ list [lsearch -nocase -all -inline [package names] tcloo] \
+ [package present TclOO] [package versions TclOO]
+} [list TclOO $::oo::patchlevel $::oo::patchlevel]
test oo-1.1 {basic test of OO functionality: no classes} {
set result {}
@@ -135,6 +131,13 @@ test oo-1.4 {basic test of OO functionality} -body {
test oo-1.5 {basic test of OO functionality} -body {
oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
+test oo-1.5.1 {basic test of OO functionality} -setup {
+ oo::object create aninstance
+} -returnCodes error -body {
+ aninstance
+} -cleanup {
+ rename aninstance {}
+} -result {wrong # args: should be "aninstance method ?arg ...?"}
test oo-1.6 {basic test of OO functionality} -setup {
oo::object create aninstance
} -body {
@@ -272,7 +275,6 @@ 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
}
@@ -335,12 +337,50 @@ test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup {
} -cleanup {
foo destroy
} -result good
+test oo-2.7 {construction, method calls and ensembles - Bug 3514761} -setup {
+ namespace eval k {}
+} -body {
+ namespace eval k {
+ oo::class create s {
+ constructor {j} {
+ # nothing
+ }
+ }
+ namespace export s
+ namespace ensemble create
+ }
+ k s create X
+} -returnCodes error -cleanup {
+ namespace delete k
+} -result {wrong # args: should be "k s create X j"}
+test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup {
+ namespace eval k {}
+} -body {
+ namespace eval k {
+ oo::class create s {
+ constructor {j} {
+ # nothing
+ }
+ }
+ oo::class create t {
+ superclass s
+ constructor args {
+ k next {*}$args
+ }
+ }
+ interp alias {} ::k::next {} ::oo::Helpers::next
+ namespace export t next
+ namespace ensemble create
+ }
+ k t create X
+} -returnCodes error -cleanup {
+ namespace delete k
+} -result {wrong # args: should be "k next j"}
test oo-3.1 {basic test of OO functionality: destructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as we're
# modifying the root object class's constructor
interp create subinterp
- initInterpreter subinterp
subinterp eval {
package require TclOO
}
@@ -361,7 +401,6 @@ test oo-3.2 {basic test of OO functionality: destructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
# we're modifying the root object class's constructor
interp create subinterp
- initInterpreter subinterp
subinterp eval {
package require TclOO
}
@@ -755,6 +794,211 @@ test oo-6.7 {OO: forward resolution scope is per-object} -setup {
} -cleanup {
fooClass destroy
} -result 1
+test oo-6.8 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {}
+ }
+ fooClass create ::foo
+ foo test
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.9 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1 2 3
+} -cleanup {
+ fooClass destroy
+} -result 1,2,3
+test oo-6.10 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1 2
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.11 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {}
+ }
+ foo test
+} -returnCodes error -cleanup {
+ foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.12 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ foo test 1 2 3
+} -cleanup {
+ foo destroy
+} -result 1,2,3
+test oo-6.13 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+ oo::object create foo
+} -body {
+ oo::objdefine foo {
+ forward test my handler
+ method handler {a b c} {list $a,$b,$c}
+ }
+ foo test 1 2
+} -returnCodes error -cleanup {
+ foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.14 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler1 p
+ forward handler1 my handler q
+ method handler {a b c} {}
+ }
+ fooClass create ::foo
+ foo test
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test c"}
+test oo-6.15 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test my handler1 p
+ forward handler1 my handler q
+ method handler {a b c} {list $a,$b,$c}
+ }
+ fooClass create ::foo
+ foo test 1
+} -cleanup {
+ fooClass destroy
+} -result q,p,1
+test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test handler1 foo bar
+ forward handler2 my handler x
+ method handler {a b c d} {list $a,$b,$c,$d}
+ export eval
+ }
+ fooClass create ::foo
+ foo eval {
+ interp alias {} [namespace current]::handler1 \
+ {} [namespace current]::my handler2
+ }
+ foo test 1 2 3
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test d"}
+test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward test handler1 foo bar boo
+ forward handler2 my handler
+ method handler {a b c d} {list $a,$b,$c,$d}
+ export eval
+ }
+ fooClass create ::foo
+ foo eval {
+ namespace ensemble create \
+ -command [namespace current]::handler1 -parameters {p q} \
+ -map [list boo [list [namespace current]::my handler2]]
+ }
+ foo test 1 2 3
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "foo test c d"}
+test oo-6.18 {Bug 3408830: more forwarding cases} -setup {
+ oo::class create fooClass
+} -body {
+ oo::define fooClass {
+ forward len string length
+ }
+ [fooClass create foo] len a b
+} -returnCodes error -cleanup {
+ fooClass destroy
+} -result {wrong # args: should be "::foo len string"}
+test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup {
+ oo::object create foo
+ unset -nocomplain ::result
+ set ::result {}
+} -body {
+ proc ::my {method} {lappend ::result global}
+ oo::objdefine foo {
+ method target {} {lappend ::result instance}
+ forward bar my target
+ method bump {} {
+ set ns [info object namespace ::foo]
+ rename ${ns}::my ${ns}::
+ rename ${ns}:: ${ns}::my
+ }
+ }
+ proc harness {} {
+ foo target
+ foo bar
+ foo target
+ }
+ trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
+ foo target
+ foo bar
+ foo bump
+ foo bar
+ harness
+} -cleanup {
+ catch {rename harness {}}
+ catch {rename ::my {}}
+ foo destroy
+} -result {instance instance instance instance instance instance}
+test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup {
+ oo::class create fooClass
+ fooClass create foo
+ unset -nocomplain ::result
+ set ::result {}
+} -body {
+ proc ::my {method} {lappend ::result global}
+ oo::define fooClass {
+ method target {} {lappend ::result class}
+ forward bar my target
+ method bump {} {
+ set ns [info object namespace [self]]
+ rename ${ns}::my ${ns}::
+ rename ${ns}:: ${ns}::my
+ }
+ }
+ proc harness {} {
+ foo target
+ foo bar
+ foo target
+ }
+ trace add execution harness enterstep {apply {{cmd args} {foo bump}}}
+ foo target
+ foo bar
+ foo bump
+ foo bar
+ harness
+} -cleanup {
+ catch {rename harness {}}
+ catch {rename ::my {}}
+ fooClass destroy
+} -result {class class class class class class}
test oo-7.1 {OO: inheritance 101} -setup {
oo::class create superClass
@@ -1515,6 +1759,116 @@ test oo-15.3 {OO: class cloning} {
bar destroy
return $result
} {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester}
+test oo-15.4 {OO: object cloning - Bug 3474460} -setup {
+ oo::class create ArbitraryClass
+} -body {
+ ArbitraryClass create foo
+ oo::objdefine foo variable a b c
+ oo::copy foo bar
+ info object variable bar
+} -cleanup {
+ ArbitraryClass destroy
+} -result {a b c}
+test oo-15.5 {OO: class cloning - Bug 3474460} -setup {
+ oo::class create ArbitraryClass
+} -body {
+ oo::class create Foo {
+ superclass ArbitraryClass
+ variable a b c
+ }
+ oo::copy Foo Bar
+ info class variable Bar
+} -cleanup {
+ ArbitraryClass destroy
+} -result {a b c}
+test oo-15.6 {OO: object cloning copies namespace contents} -setup {
+ oo::class create ArbitraryClass {export eval}
+} -body {
+ ArbitraryClass create a
+ a eval {proc foo x {
+ variable y
+ return [string repeat $x [incr y]]
+ }}
+ set result [list [a eval {foo 2}] [a eval {foo 3}]]
+ oo::copy a b
+ a eval {rename foo bar}
+ lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}]
+} -cleanup {
+ ArbitraryClass destroy
+} -result {2 33 222 3333 444}
+test oo-15.7 {OO: classes can be cloned anonymously} -setup {
+ oo::class create ArbitraryClassA
+ oo::class create ArbitraryClassB {superclass ArbitraryClassA}
+} -body {
+ info object isa class [oo::copy ArbitraryClassB]
+} -cleanup {
+ ArbitraryClassA destroy
+} -result 1
+test oo-15.8 {OO: intercept object cloning} -setup {
+ oo::class create Foo
+ set result {}
+} -body {
+ oo::define Foo {
+ constructor {msg} {
+ variable v $msg
+ }
+ method <cloned> {from} {
+ next $from
+ lappend ::result cloned $from [self]
+ }
+ method check {} {
+ variable v
+ lappend ::result check [self] $v
+ }
+ }
+ Foo create foo ok
+ oo::copy foo bar
+ foo check
+ bar check
+} -cleanup {
+ Foo destroy
+} -result {cloned ::foo ::bar check ::foo ok check ::bar ok}
+test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup {
+ oo::class create Foo
+} -body {
+ oo::define Foo {
+ method <cloned> {a b} {}
+ }
+ interp alias {} Bar {} oo::copy [Foo create foo]
+ Bar bar
+} -returnCodes error -cleanup {
+ Foo destroy
+} -result {wrong # args: should be "::bar <cloned> a b"}
+test oo-15.10 {variable binding must not bleed through oo::copy} -setup {
+ oo::class create FooClass
+ set result {}
+} -body {
+ set obj1 [FooClass new]
+ oo::objdefine $obj1 {
+ variable var
+ method m {} {
+ set var foo
+ }
+ method get {} {
+ return $var
+ }
+ export eval
+ }
+
+ $obj1 m
+ lappend result [$obj1 get]
+ set obj2 [oo::copy $obj1]
+ $obj2 eval {
+ set var bar
+ }
+ lappend result [$obj2 get]
+ $obj1 eval {
+ set var grill
+ }
+ lappend result [$obj1 get] [$obj2 get]
+} -cleanup {
+ FooClass destroy
+} -result {foo bar grill bar}
test oo-16.1 {OO: object introspection} -body {
info object
@@ -1524,7 +1878,7 @@ test oo-16.2 {OO: object introspection} -body {
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
info object gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
oo::class create meta { superclass oo::class }
[meta create instance1] create instance2
@@ -1610,10 +1964,10 @@ test oo-16.11 {OO: object introspection} -setup {
} -body {
oo::define foo method spong {} {...}
oo::objdefine bar method boo {a {b c} args} {the body}
- list [info object methods bar -all] [info object methods bar -all -private]
+ list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]]
} -cleanup {
foo destroy
-} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}}
+} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}}
test oo-16.12 {OO: object introspection} -setup {
oo::object create foo
} -cleanup {
@@ -1646,7 +2000,7 @@ test oo-17.3 {OO: class introspection} -setup {
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
info class gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
@@ -1694,11 +2048,11 @@ test oo-17.9 {OO: class introspection} -setup {
}
}
oo::define subfoo method boo {a {b c} args} {the body}
- list [info class methods subfoo -all] \
- [info class methods subfoo -all -private]
+ list [lsort [info class methods subfoo -all]] \
+ [lsort [info class methods subfoo -all -private]]
} -cleanup {
foo destroy
-} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}}
+} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}}
test oo-17.10 {OO: class introspection} -setup {
oo::class create foo
} -cleanup {
@@ -1713,7 +2067,7 @@ test oo-18.1 {OO: define command support} {
} {1 foo {foo
while executing
"error foo"
- (in definition script for object "oo::object" line 1)
+ (in definition script for class "::oo::object" line 1)
invoked from within
"oo::define oo::object {error foo}"}}
test oo-18.2 {OO: define command support} {
@@ -1726,7 +2080,7 @@ test oo-18.3 {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 1)
+ (in definition script for class "::foo" line 1)
invoked from within
"oo::class create foo {error bar}"}}
test oo-18.3a {OO: define command support} {
@@ -1736,7 +2090,7 @@ test oo-18.3a {OO: define command support} {
} {1 bar {bar
while executing
"error bar"
- (in definition script for object "::foo" line 2)
+ (in definition script for class "::foo" line 2)
invoked from within
"oo::class create foo {
error bar
@@ -1754,7 +2108,7 @@ test oo-18.3b {OO: define command support} {
("eval" body line 1)
invoked from within
"eval eval error bar"
- (in definition script for object "::foo" line 2)
+ (in definition script for class "::foo" line 2)
invoked from within
"oo::class create foo {
eval eval error bar
@@ -1809,6 +2163,106 @@ test oo-18.5 {OO: more error traces from the guts} -setup {
(class "::cls" method "eval" line 1)
invoked from within
"obj eval {error bar}"}}
+test oo-18.6 {class construction reference management and errors} -setup {
+ oo::class create super_abc
+} -body {
+ catch {
+oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}
+ } msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ super_abc destroy
+} -result {foo
+ while executing
+"::error foo"
+ (in definition script for class "::def" line 4)
+ invoked from within
+"oo::class create abc {
+ superclass super_abc
+ ::rename abc ::def
+ ::error foo
+}"}
+test oo-18.7 {OO: objdefine command support} -setup {
+ oo::object create ::inst
+} -body {
+ list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo
+} -cleanup {
+ catch {::inst destroy}
+ catch {::INST destroy}
+} -result {1 foo {foo
+ while executing
+"error foo"
+ (in definition script for object "::INST" line 1)
+ invoked from within
+"oo::objdefine inst {rename ::inst ::INST;error foo}"}}
+test oo-18.8 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::bar" line 1)
+ invoked from within
+"self {error foobar}"
+ (in definition script for class "::bar" line 1)
+ invoked from within
+"oo::define foo {rename ::foo ::bar; self {error foobar}}"}
+test oo-18.9 {OO: define/self command support} -setup {
+ oo::class create master
+ set c [oo::class create now_this_is_a_very_very_long_class_name_indeed {
+ superclass master
+ }]
+} -body {
+ catch {oo::define $c {error err}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {err
+ while executing
+"error err"
+ (in definition script for class "::now_this_is_a_very_very_long..." line 1)
+ invoked from within
+"oo::define $c {error err}"}
+test oo-18.10 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {foobar
+ while executing
+"error foobar"
+ (in definition script for class object "::foo" line 1)
+ invoked from within
+"self {rename ::foo {}; error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {self {rename ::foo {}; error foobar}}"}
+test oo-18.11 {OO: define/self command support} -setup {
+ oo::class create master
+ oo::class create ::foo {superclass master}
+} -body {
+ catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt
+ dict get $opt -errorinfo
+} -cleanup {
+ master destroy
+} -result {this command cannot be called when the object has been deleted
+ while executing
+"self {error foobar}"
+ (in definition script for class "::foo" line 1)
+ invoked from within
+"oo::define foo {rename ::foo {}; self {error foobar}}"}
test oo-19.1 {OO: varname method} -setup {
oo::object create inst
@@ -1843,6 +2297,25 @@ test oo-19.2 {OO: varname method: Bug 2883857} -setup {
} -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 {
@@ -2232,7 +2705,7 @@ test oo-22.1 {OO and info frame} -setup {
list [i level] [i frames] [dict get [c frame] object]
} -cleanup {
c destroy
-} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}
+} -result {1 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c}
test oo-22.2 {OO and info frame: Bug 3001438} -setup {
oo::class create c
} -body {
@@ -2303,6 +2776,16 @@ test oo-24.2 {unknown method method - Bug 1965063} -setup {
}
obj foo bar
} -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
+test oo-24.3 {unknown method method - absent method name} -setup {
+ set o [oo::object new]
+} -cleanup {
+ $o destroy
+} -body {
+ oo::objdefine $o method unknown args {
+ return "unknown: >>$args<<"
+ }
+ list [$o] [$o foobar] [$o foo bar]
+} -result {{unknown: >><<} {unknown: >>foobar<<} {unknown: >>foo bar<<}}
# Probably need a better set of tests, but this is quite difficult to devise
test oo-25.1 {call chain caching} -setup {
@@ -2594,6 +3077,173 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management}
} -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...
@@ -2675,6 +3325,184 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
} -cleanup {
cls destroy
} -result {0 {}}
+
+oo::class create SampleSlot {
+ superclass oo::Slot
+ constructor {} {
+ variable contents {a b c} ops {}
+ }
+ method contents {} {variable contents; return $contents}
+ method ops {} {variable ops; return $ops}
+ method Get {} {
+ variable contents
+ variable ops
+ lappend ops [info level] Get
+ return $contents
+ }
+ method Set {lst} {
+ variable contents $lst
+ variable ops
+ lappend ops [info level] Set $lst
+ return
+ }
+}
+
+test oo-32.1 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -clear] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -append g h i] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -set d e f] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup {
+ SampleSlot create sampleSlot
+} -body {
+ list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+ rename sampleSlot {}
+} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+
+test oo-33.1 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ list [$s x y] [$s contents]
+} -cleanup {
+ rename $s {}
+} -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ list [$s destroy; $s unknown] [$s contents]
+} -cleanup {
+ rename $s {}
+} -result {{} {a b c destroy unknown}}
+test oo-33.3 {TIP 380: slots - defaulting} -setup {
+ set s [SampleSlot new]
+} -body {
+ oo::objdefine $s forward --default-operation my -set
+ list [$s destroy; $s unknown] [$s contents] [$s ops]
+} -cleanup {
+ rename $s {}
+} -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup {
+ set s [SampleSlot new]
+} -body {
+ # Method names beginning with "-" are special to slots
+ $s -grill q
+} -returnCodes error -cleanup {
+ rename $s {}
+} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
+
+SampleSlot destroy
+
+test oo-34.1 {TIP 380: slots - presence} -setup {
+ set obj [oo::object new]
+ set result {}
+} -body {
+ oo::define oo::object {
+ ::lappend ::result [::info object class filter]
+ ::lappend ::result [::info object class mixin]
+ ::lappend ::result [::info object class superclass]
+ ::lappend ::result [::info object class variable]
+ }
+ oo::objdefine $obj {
+ ::lappend ::result [::info object class filter]
+ ::lappend ::result [::info object class mixin]
+ ::lappend ::result [::info object class variable]
+ }
+ return $result
+} -cleanup {
+ $obj destroy
+} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
+test oo-34.2 {TIP 380: slots - presence} {
+ lsort [info class instances oo::Slot]
+} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
+proc getMethods obj {
+ list [lsort [info object methods $obj -all]] \
+ [lsort [info object methods $obj -private]]
+}
+test oo-34.3 {TIP 380: slots - presence} {
+ getMethods oo::define::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.4 {TIP 380: slots - presence} {
+ getMethods oo::define::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.5 {TIP 380: slots - presence} {
+ getMethods oo::define::superclass
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.6 {TIP 380: slots - presence} {
+ getMethods oo::define::variable
+} {{-append -clear -set} {Get Set}}
+test oo-34.7 {TIP 380: slots - presence} {
+ getMethods oo::objdefine::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.8 {TIP 380: slots - presence} {
+ getMethods oo::objdefine::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.9 {TIP 380: slots - presence} {
+ getMethods oo::objdefine::variable
+} {{-append -clear -set} {Get Set}}
+
+test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
+ oo::class create fruit {
+ method eat {} {}
+ }
+ set result {}
+} -body {
+ lappend result [fruit create ::apple] [info class superclasses fruit]
+ oo::define fruit superclass
+ lappend result [info class superclasses fruit] \
+ [info object class apple oo::object] \
+ [info class call fruit destroy] \
+ [catch { apple }]
+} -cleanup {
+ unset -nocomplain result
+ fruit destroy
+} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1}
+test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
+ oo::class create fruitMetaclass {
+ superclass oo::class
+ method eat {} {}
+ }
+ set result {}
+} -body {
+ lappend result [fruitMetaclass create ::appleClass] \
+ [appleClass create orange] \
+ [info class superclasses fruitMetaclass]
+ oo::define fruitMetaclass superclass
+ lappend result [info class superclasses fruitMetaclass] \
+ [info object class appleClass oo::class] \
+ [catch { orange }] [info object class orange] \
+ [appleClass create pear]
+} -cleanup {
+ unset -nocomplain result
+ fruitMetaclass destroy
+} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear}
cleanupTests
return
generated by cgit v0.12 at 2025-11-03 15:19:02 (GMT)