summaryrefslogtreecommitdiffstats
path: root/tests/oo.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/oo.test')
-rw-r--r--tests/oo.test1372
1 files changed, 1335 insertions, 37 deletions
diff --git a/tests/oo.test b/tests/oo.test
index db5c14f..0f8cd47 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -13,13 +13,11 @@ if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
-
# The foundational objects oo::object and oo::class are sensitive to reference
# counting errors and are deallocated only when an interp is deleted, so in
# this test suite, interp creation and interp deletion are often used in
# leaktests in order to leverage this sensitivity.
-
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
@@ -131,18 +129,18 @@ test oo-1.1 {basic test of OO functionality: no classes} {
} {::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\""
+} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? 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\"
+} "wrong # args: should be \"oo::define oo::object method name ?option? 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.4.1 {fully-qualified nested name} -body {
- oo::object create ::one::two::three
+ oo::object create ::one::two::three
} -result {::one::two::three}
test oo-1.4.2 {automatic command name has same name as namespace} -body {
set obj [oo::object new]
@@ -314,7 +312,7 @@ test oo-1.18.3 {Bug 21c144f0f5} -setup {
}
} -cleanup {
interp delete slave
-}
+}
test oo-1.19 {basic test of OO functionality: teardown order} -body {
oo::object create o
namespace delete [info object namespace o]
@@ -331,19 +329,20 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
set fresh [interp create]
} -body {
lmap x [$fresh eval {
+ set initials {::oo::object ::oo::class ::oo::Slot}
foreach cmd {instances subclasses mixins superclass} {
- foreach initial {object class Slot} {
- lappend x [info class $cmd ::oo::$initial]
+ foreach initial $initials {
+ lappend x [info class $cmd $initial]
}
}
- foreach initial {object class Slot} {
- lappend x [info object class ::oo::$initial]
+ foreach initial $initials {
+ lappend x [info object class $initial]
}
return $x
- }] {lsort $x}
+ }] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
interp delete $fresh
-} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
+} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
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
@@ -780,6 +779,76 @@ test oo-4.6 {export creates proper method entries} -setup {
} -cleanup {
testClass destroy
} -result ok
+test oo-4.7 {basic test of OO functionality: method -export flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method Foo {} {
+ lappend ::result Foo
+ return foo
+ }
+ method Bar -export {} {
+ lappend ::result Bar
+ return bar
+ }
+ }
+ lappend result [catch {$o Foo} msg] $msg
+ lappend result [$o Bar]
+} -cleanup {
+ $o destroy
+} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar}
+test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method foo {} {
+ lappend ::result foo
+ return Foo
+ }
+ method bar -unexport {} {
+ lappend ::result bar
+ return Bar
+ }
+ }
+ lappend result [$o foo]
+ lappend result [catch {$o bar} msg] $msg
+} -cleanup {
+ $o destroy
+} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}}
+test oo-4.9 {basic test of OO functionality: method -private flag} -setup {
+ set o [oo::object new]
+ unset -nocomplain result
+} -body {
+ oo::objdefine $o {
+ method foo {} {
+ lappend ::result foo
+ return Foo
+ }
+ method bar -private {} {
+ lappend ::result bar
+ return Bar
+ }
+ export eval
+ method gorp {} {
+ my bar
+ }
+ }
+ lappend result [$o foo]
+ lappend result [catch {$o bar} msg] $msg
+ lappend result [catch {$o eval my bar} msg] $msg
+ lappend result [$o gorp]
+} -cleanup {
+ $o destroy
+} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be <cloned>, destroy, eval, foo, gorp, unknown, variable or varname} bar Bar}
+test oo-4.10 {basic test of OO functionality: method flag parsing} -setup {
+ set o [oo::object new]
+} -body {
+ oo::objdefine $o method foo -gorp xyz {return Foo}
+} -returnCodes error -cleanup {
+ $o destroy
+} -result {bad export flag "-gorp": must be -export, -private, or -unexport}
test oo-5.1 {OO: manipulation of classes as objects} -setup {
set obj [oo::object new]
@@ -1583,10 +1652,10 @@ test oo-11.6.4 {
instances
} -body {
oo::class create obj1
- ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+ ::oo::define obj1 {self mixin [self]}
::oo::copy obj1 obj2
- ::oo::objdefine obj2 {mixin [uplevel 1 {namespace which obj2}]}
+ ::oo::objdefine obj2 {mixin [self]}
::oo::copy obj2 obj3
rename obj3 {}
@@ -2204,7 +2273,7 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup {
} -body {
set obj1 [FooClass new]
oo::objdefine $obj1 {
- variable var
+ variable var
method m {} {
set var foo
}
@@ -2253,7 +2322,7 @@ test oo-15.13.1 {
} -cleanup {
Cls destroy
Cls2 destroy
-} -result done
+} -result done
test oo-15.13.2 {OO: object cloning with target NS} -setup {
oo::class create Super
oo::class create Cls {superclass Super}
@@ -2281,7 +2350,7 @@ test oo-15.15 {method cloning must ensure that there is a string representation
} -body {
cls create foo
oo::objdefine foo {
- method m1 {} [string map {a b} {return hello}]
+ method m1 {} [string map {a b} {return hello}]
}
[oo::copy foo] m1
} -cleanup {
@@ -2302,7 +2371,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 call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, 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
@@ -2432,6 +2501,73 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup {
} -cleanup {
meta destroy
} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
+test oo-16.15 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ info object creationid [cls new]
+} -cleanup {
+ cls destroy
+} -result {^\d+$} -match regexp
+test oo-16.16 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ set obj [cls new]
+ set id [info object creationid $obj]
+ rename $obj gorp
+ set id2 [info object creationid gorp]
+ list $id $id2
+} -cleanup {
+ cls destroy
+} -result {^(\d+) \1$} -match regexp
+test oo-16.17 {OO: object introspection: creationid #500} -body {
+ info object creationid nosuchobject
+} -returnCodes error -result {nosuchobject does not refer to an object}
+test oo-16.18 {OO: object introspection: creationid #500} -body {
+ info object creationid
+} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
+test oo-16.18 {OO: object introspection: creationid #500} -body {
+ info object creationid oo::object gorp
+} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
+test oo-16.19 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ set id1 [info object creationid [set o1 [cls new]]]
+ set id2 [info object creationid [set o2 [cls new]]]
+ if {$id1 == $id2} {
+ format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+ } else {
+ string cat not-equal
+ }
+} -cleanup {
+ cls destroy
+} -result not-equal
+test oo-16.20 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ set id1 [info object creationid [set o1 [cls new]]]
+ $o1 destroy
+ set id2 [info object creationid [set o2 [cls new]]]
+ if {$id1 == $id2} {
+ format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+ } else {
+ string cat not-equal
+ }
+} -cleanup {
+ cls destroy
+} -result not-equal
+test oo-16.21 {OO: object introspection: creationid #500} -setup {
+ oo::class create cls
+} -body {
+ set id1 [info object creationid [set o1 [cls new]]]
+ set id2 [info object creationid [set o2 [oo::copy $o1]]]
+ if {$id1 == $id2} {
+ format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
+ } else {
+ string cat not-equal
+ }
+} -cleanup {
+ cls destroy
+} -result not-equal
test oo-17.1 {OO: class introspection} -body {
info class
@@ -2454,7 +2590,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 call, 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, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
@@ -2553,6 +2689,7 @@ test oo-17.14 {OO: instance method unexport (bug 900cb0284bc)} -setup {
c destroy
} -result $stdmethods
+
test oo-18.1 {OO: define command support} {
list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo
} {1 foo {foo
@@ -2942,7 +3079,7 @@ test oo-20.10 {OO: variable and varname methods refer to same things} -setup {
test oo-20.11 {OO: variable mustn't crash when recursing} -body {
oo::class create A {
constructor {name} {
- my variable np_name
+ my variable np_name
set np_name $name
}
method copy {nm} {
@@ -2957,7 +3094,7 @@ test oo-20.11 {OO: variable mustn't crash when recursing} -body {
lappend objs [$ref copy {}]
}
$cpy prop $var $objs
- } else {
+ } else {
$cpy prop $var $val
}
}
@@ -3870,6 +4007,11 @@ proc SampleSlotSetup script {
lappend ops [info level] Set $lst
return
}
+ method Resolve {lst} {
+ variable ops
+ lappend ops [info level] Resolve $lst
+ return $lst
+ }
}
}
append script0 \n$script
@@ -3904,7 +4046,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}}
test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
@@ -3912,7 +4054,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-}] -result {0 {} {d e f} {1 Set {d e f}}}
+}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}}
test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
}] -body {
@@ -3920,7 +4062,23 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
[sampleSlot contents] [sampleSlot ops]
} -cleanup [SampleSlotCleanup {
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}}}
+}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}}
+test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
+ SampleSlot create sampleSlot
+}] -body {
+ list [info level] [sampleSlot -prepend g h i] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup [SampleSlotCleanup {
+ rename sampleSlot {}
+}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}}
+test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup {
+ SampleSlot create sampleSlot
+}] -body {
+ list [info level] [sampleSlot -remove c a] \
+ [sampleSlot contents] [sampleSlot ops]
+} -cleanup [SampleSlotCleanup {
+ rename sampleSlot {}
+}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}}
test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
@@ -3943,7 +4101,7 @@ test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
list [$s destroy; $s unknown] [$s contents] [$s ops]
} -cleanup [SampleSlotCleanup {
rename $s {}
-}] -result {{} unknown {1 Set destroy 1 Set unknown}}
+}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}}
test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
set s [SampleSlot new]
}] -body {
@@ -3952,7 +4110,7 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
} -returnCodes error -cleanup [SampleSlotCleanup {
rename $s {}
}] -result \
- {unknown method "-grill": must be -append, -clear, -set, contents or ops}
+ {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]
@@ -3982,25 +4140,68 @@ proc getMethods obj {
}
test oo-34.3 {TIP 380: slots - presence} {
getMethods oo::define::filter
-} {{-append -clear -set} {Get Set}}
+} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
getMethods oo::define::mixin
-} {{-append -clear -set} {--default-operation Get Set}}
+} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.5 {TIP 380: slots - presence} {
getMethods oo::define::superclass
-} {{-append -clear -set} {--default-operation Get Set}}
+} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.6 {TIP 380: slots - presence} {
getMethods oo::define::variable
-} {{-append -clear -set} {Get Set}}
+} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
getMethods oo::objdefine::filter
-} {{-append -clear -set} {Get Set}}
+} {{-append -clear -prepend -remove -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
getMethods oo::objdefine::mixin
-} {{-append -clear -set} {--default-operation Get Set}}
+} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.9 {TIP 380: slots - presence} {
getMethods oo::objdefine::variable
-} {{-append -clear -set} {Get Set}}
+} {{-append -clear -prepend -remove -set} {Get Set}}
+test oo-34.10 {TIP 516: slots - resolution} -setup {
+ oo::class create parent
+ set result {}
+ oo::class create 516a { superclass parent }
+ oo::class create 516b { superclass parent }
+ oo::class create 516c { superclass parent }
+ namespace eval 516test {
+ oo::class create 516a { superclass parent }
+ oo::class create 516b { superclass parent }
+ oo::class create 516c { superclass parent }
+ }
+} -body {
+ # Must find the right classes when making the mixin
+ namespace eval 516test {
+ oo::define 516a {
+ mixin 516b 516c
+ }
+ }
+ lappend result [info class mixin 516test::516a]
+ # Must not remove class with just simple name match
+ oo::define 516test::516a {
+ mixin -remove 516b
+ }
+ lappend result [info class mixin 516test::516a]
+ # Must remove class with resolved name match
+ oo::define 516test::516a {
+ mixin -remove 516test::516c
+ }
+ lappend result [info class mixin 516test::516a]
+ # Must remove class with resolved name match even after renaming, but only
+ # with the renamed name; it is a slot of classes, not strings!
+ rename 516test::516b 516test::516d
+ oo::define 516test::516a {
+ mixin -remove 516test::516b
+ }
+ lappend result [info class mixin 516test::516a]
+ oo::define 516test::516a {
+ mixin -remove 516test::516d
+ }
+ lappend result [info class mixin 516test::516a]
+} -cleanup {
+ parent destroy
+} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}}
test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup {
oo::class create fruit {
@@ -4072,8 +4273,6 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly}
} -cleanup {
base destroy
} -result {{c d e} {c d e}}
-
-
test oo-35.6 {
Bug : teardown of an object that is a class that is an instance of itself
} -setup {
@@ -4094,13 +4293,1112 @@ test oo-35.6 {
return done
} -cleanup {
rename obj {}
-} -result done
+} -result done
+
+test oo-36.1 {TIP #470: introspection within oo::define} {
+ oo::define oo::object self
+} ::oo::object
+test oo-36.2 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+} -body {
+ oo::define Cls self
+} -cleanup {
+ Cls destroy
+} -result ::Cls
+test oo-36.3 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self]
+ }
+ return $result
+} -cleanup {
+ Super destroy
+} -result ::Sub
+test oo-36.4 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self {}]
+ }
+ return $result
+} -cleanup {
+ Super destroy
+} -result {}
+test oo-36.5 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Super
+ set result uncalled
+} -body {
+ oo::class create Sub {
+ superclass Super
+ ::set ::result [self self]
+ }
+} -cleanup {
+ Super destroy
+} -result ::Sub
+test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ ::set ::result [self]
+ }
+} -cleanup {
+ Cls destroy
+} -result ::obj
+test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ self
+ }
+} -cleanup {
+ Cls destroy
+} -result ::obj
+test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup {
+ oo::class create Cls
+} -body {
+ Cls create obj
+ oo::objdefine obj {
+ self anything
+ }
+} -returnCodes error -cleanup {
+ Cls destroy
+} -result {wrong # args: should be "self"}
+test oo-36.9 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ proc oo::define::testself {} {
+ global result
+ set result [list [catch {self} msg] $msg \
+ [catch {uplevel 1 self} msg] $msg]
+ return
+ }
+ list [oo::define Cls testself] $result
+} -cleanup {
+ Cls destroy
+ catch {rename oo::define::testself {}}
+} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}}
+test oo-36.10 {TIP #470: introspection within oo::define} -setup {
+ oo::class create Cls
+ set result uncalled
+} -body {
+ proc oo::objdefine::testself {} {
+ global result
+ set result [list [catch {self} msg] $msg \
+ [catch {uplevel 1 self} msg] $msg]
+ return
+ }
+ Cls create obj
+ list [oo::objdefine obj testself] $result
+} -cleanup {
+ Cls destroy
+ catch {rename oo::objdefine::testself {}}
+} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
+test oo-37.1 {TIP 500: private command propagates errors} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ private ::error "this is an error"
+ }
+} -cleanup {
+ cls destroy
+} -returnCodes error -result {this is an error}
+test oo-37.2 {TIP 500: private command propagates errors} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ private {
+ ::error "this is an error"
+ }
+ }
+} -cleanup {
+ cls destroy
+} -returnCodes error -result {this is an error}
+test oo-37.3 {TIP 500: private command propagates errors} -setup {
+ oo::object create obj
+} -body {
+ oo::objdefine obj {
+ private ::error "this is an error"
+ }
+} -cleanup {
+ obj destroy
+} -returnCodes error -result {this is an error}
+test oo-37.4 {TIP 500: private command propagates errors} -setup {
+ oo::object create obj
+} -body {
+ oo::objdefine obj {
+ private {
+ ::error "this is an error"
+ }
+ }
+} -cleanup {
+ obj destroy
+} -returnCodes error -result {this is an error}
+test oo-37.5 {TIP 500: private command can't be used outside definitions} -body {
+ oo::define::private error "xyz"
+} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
+test oo-37.6 {TIP 500: private command can't be used outside definitions} -body {
+ oo::objdefine::private error "xyz"
+} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
+test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ private variable x
+ constructor {} {
+ set x 1
+ }
+ method getA {} {
+ return $x
+ }
+ }
+ oo::class create clsB {
+ superclass clsA
+ private {
+ variable x
+ }
+ constructor {} {
+ set x 2
+ next
+ }
+ method getB {} {
+ return $x
+ }
+ }
+ oo::class create clsC {
+ superclass clsB
+ variable x
+ constructor {} {
+ set x 3
+ next
+ }
+ method getC {} {
+ return $x
+ }
+ }
+ clsC create obj
+ oo::objdefine obj {
+ private {
+ variable x
+ }
+ method setup {} {
+ set x 4
+ }
+ method getO {} {
+ return $x
+ }
+ }
+ obj setup
+ list [obj getA] [obj getB] [obj getC] [obj getO] \
+ [lsort [string map [list [info object creationid clsA] CLASS-A \
+ [info object creationid clsB] CLASS-B \
+ [info object creationid obj] OBJ] \
+ [info object vars obj]]]
+} -cleanup {
+ parent destroy
+} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}}
+test oo-38.2 {TIP 500: private variables introspection} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ private {
+ variable x1
+ variable x2
+ }
+ variable y1 y2
+ }
+ cls create obj
+ oo::objdefine obj {
+ private variable a1 a2
+ variable b1 b2
+ }
+ list [lsort [info class variables cls]] \
+ [lsort [info class variables cls -private]] \
+ [lsort [info object variables obj]] \
+ [lsort [info object variables obj -private]]
+} -cleanup {
+ parent destroy
+} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}}
+test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ private {
+ variable x
+ }
+ method getx {} {
+ set x 1
+ my varname x
+ }
+ method readx {} {
+ return $x
+ }
+ }
+ oo::class create clsB {
+ superclass clsA
+ variable x
+ method gety {} {
+ set x 1
+ my varname x
+ }
+ method ready {} {
+ return $x
+ }
+ }
+ clsB create obj
+ set [obj getx] 2
+ set [obj gety] 3
+ list [obj readx] [obj ready]
+} -cleanup {
+ parent destroy
+} -result {2 3}
+test oo-38.4 {TIP 500: private variables introspection} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ private {
+ variable x1 x2
+ }
+ variable y1 y2
+ constructor {} {
+ variable z boo
+ set x1 a
+ set y1 c
+ }
+ method list {} {
+ variable z
+ set ok 1
+ list [info locals] [lsort [info vars]] [info exist x2]
+ }
+ }
+ cls create obj
+ oo::objdefine obj {
+ private variable a1 a2
+ variable b1 b2
+ method init {} {
+ # Because we don't have a constructor to do this setup for us
+ set a1 p
+ set b1 r
+ }
+ method list {} {
+ variable z
+ set yes 1
+ list {*}[next] [info locals] [lsort [info vars]] [info exist a2]
+ }
+ }
+ obj init
+ obj list
+} -cleanup {
+ parent destroy
+} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0}
+test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ private variable x
+ method abc val {
+ my variable x
+ set x $val
+ }
+ method def val {
+ my variable y
+ set y $val
+ }
+ method get1 {} {
+ my variable x y
+ return [list $x $y]
+ }
+ }
+ oo::class create cls2 {
+ superclass cls1
+ private variable x
+ method x-exists {} {
+ return [info exists x],[uplevel 1 {info exists x}]
+ }
+ method ghi x {
+ # Additional instrumentation to show that we're not using the
+ # resolved variable until we ask for it; the argument nixed that
+ # happening by default.
+ set val $x
+ set before [my x-exists]
+ unset x
+ set x $val
+ set mid [my x-exists]
+ unset x
+ set mid2 [my x-exists]
+ my variable x
+ set x $val
+ set after [my x-exists]
+ return "$before;$mid;$mid2;$after"
+ }
+ method jkl val {
+ my variable y
+ set y $val
+ }
+ method get2 {} {
+ my variable x y
+ return [list $x $y]
+ }
+ }
+ cls2 create a
+ a abc 123
+ a def 234
+ set tmp [a ghi 345]
+ a jkl 456
+ list $tmp [a get1] [a get2]
+} -cleanup {
+ parent destroy
+} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}}
+
+test oo-39.1 {TIP 500: private methods internal call; class private} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ variable x
+ constructor {} {
+ set x 1
+ }
+ method act {} {
+ my step
+ my step
+ my step
+ return
+ }
+ private {
+ method step {} {
+ incr x 2
+ }
+ }
+ method x {} {
+ return $x
+ }
+ }
+ clsA create obj
+ obj act
+ list [obj x] [catch {obj step} msg] $msg
+} -cleanup {
+ parent destroy
+} -result {7 1 {unknown method "step": must be act, destroy or x}}
+test oo-39.2 {TIP 500: private methods internal call; class private} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ variable x
+ constructor {} {
+ set x 1
+ }
+ method act {} {
+ my step
+ my step
+ my step
+ return
+ }
+ private {
+ method step {} {
+ incr x 2
+ }
+ }
+ method x {} {
+ return $x
+ }
+ }
+ oo::class create clsB {
+ superclass clsA
+ variable x
+ method step {} {
+ incr x 5
+ }
+ }
+ clsB create obj
+ obj act
+ list [obj x] [obj step]
+} -cleanup {
+ parent destroy
+} -result {7 12}
+test oo-39.3 {TIP 500: private methods internal call; class private} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ variable x
+ constructor {} {
+ set x 1
+ }
+ method act {} {
+ my Step
+ my Step
+ my Step
+ return
+ }
+ method x {} {
+ return $x
+ }
+ }
+ oo::class create clsB {
+ superclass clsA
+ variable x
+ method Step {} {
+ incr x 5
+ }
+ }
+ clsB create obj
+ obj act
+ set result [obj x]
+ oo::define clsA {
+ private {
+ method Step {} {
+ incr x 2
+ }
+ }
+ }
+ obj act
+ lappend result [obj x]
+} -cleanup {
+ parent destroy
+} -result {16 22}
+test oo-39.4 {TIP 500: private methods internal call; instance private} -setup {
+ oo::class create parent
+} -body {
+ oo::class create clsA {
+ superclass parent
+ variable x
+ constructor {} {
+ set x 1
+ }
+ method act {} {
+ my step
+ return
+ }
+ method step {} {
+ incr x
+ }
+ method x {} {
+ return $x
+ }
+ }
+ clsA create obj
+ obj act
+ set result [obj x]
+ oo::objdefine obj {
+ variable x
+ private {
+ method step {} {
+ incr x 2
+ }
+ }
+ }
+ obj act
+ lappend result [obj x]
+ oo::objdefine obj {
+ method act {} {
+ my step
+ next
+ }
+ }
+ obj act
+ lappend result [obj x]
+} -cleanup {
+ parent destroy
+} -result {2 3 6}
+test oo-39.5 {TIP 500: private methods internal call; cross object} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ method equal {other} {
+ expr {$x == [$other x]}
+ }
+ }
+ cls create a 1
+ cls create b 2
+ cls create c 1
+ list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg
+} -cleanup {
+ parent destroy
+} -result {0 0 1 1 {unknown method "x": must be destroy or equal}}
+test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ method equal {other} {
+ expr {$x == [$other y]}
+ }
+ }
+ cls create a 1
+ cls create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "y": must be destroy, equal or x}
+test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ method equal {other} {
+ expr {[[self] y] == [$other x]}
+ }
+ }
+ cls create a 1
+ cls create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "y": must be destroy, equal or x}
+test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ method equal {other} {
+ expr {[my y] == [$other x]}
+ }
+ }
+ cls create a 1
+ cls create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x}
+test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ }
+ oo::class create cls2 {
+ superclass cls
+ method equal {other} {
+ expr {[my y] == [$other x]}
+ }
+ }
+ cls2 create a 1
+ cls2 create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
+test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ variable x
+ constructor {val} {
+ set x $val
+ }
+ private method x {} {
+ return $x
+ }
+ }
+ oo::class create cls2 {
+ superclass cls
+ method equal {other} {
+ expr {[my x] == [$other x]}
+ }
+ }
+ cls2 create a 1
+ cls2 create b 2
+ a equal b
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
+test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ method chain {} {
+ return [self call]
+ }
+ }
+ oo::class create cls2 {
+ superclass cls
+ private method chain {} {
+ next
+ }
+ method chain2 {} {
+ my chain
+ }
+ method chain3 {} {
+ [self] chain
+ }
+ }
+ cls create a
+ cls2 create b
+ list [a chain] [b chain] [b chain2] [b chain3]
+} -cleanup {
+ parent destroy
+} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}}
+test oo-39.12 {TIP 500: private methods; introspection} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ method chain {} {
+ return [self call]
+ }
+ private method abc {} {}
+ }
+ oo::class create cls2 {
+ superclass cls
+ method chain2 {} {
+ my chain
+ }
+ method chain3 {} {
+ [self] chain
+ }
+ private method def {} {}
+ unexport chain3
+ }
+ cls create a
+ cls2 create b
+ oo::objdefine b {
+ private method ghi {} {}
+ method ABC {} {}
+ method foo {} {}
+ }
+ set scopes {public unexported private}
+ list a: [lmap s $scopes {info object methods a -scope $s}] \
+ b: [lmap s $scopes {info object methods b -scope $s}] \
+ cls: [lmap s $scopes {info class methods cls -scope $s}] \
+ cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \
+} -cleanup {
+ parent destroy
+} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}}
+
+test oo-40.1 {TIP 500: private and self} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ self {
+ private {
+ variable a
+ }
+ variable b
+ }
+ private {
+ self {
+ variable c
+ }
+ variable d
+ }
+ variable e
+ }
+ list \
+ [lsort [info class variables cls]] \
+ [lsort [info class variables cls -private]] \
+ [lsort [info object variables cls]] \
+ [lsort [info object variables cls -private]]
+} -cleanup {
+ cls destroy
+} -result {e d b {a c}}
+test oo-40.2 {TIP 500: private and export} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ private method foo {} {}
+ }
+ set result [lmap s {public unexported private} {
+ info class methods cls -scope $s}]
+ oo::define cls {
+ export foo
+ }
+ lappend result {*}[lmap s {public unexported private} {
+ info class methods cls -scope $s}]
+} -cleanup {
+ cls destroy
+} -result {{} {} foo foo {} {}}
+test oo-40.3 {TIP 500: private and unexport} -setup {
+ oo::class create cls
+} -body {
+ oo::define cls {
+ private method foo {} {}
+ }
+ set result [lmap s {public unexported private} {
+ info class methods cls -scope $s}]
+ oo::define cls {
+ unexport foo
+ }
+ lappend result {*}[lmap s {public unexported private} {
+ info class methods cls -scope $s}]
+} -cleanup {
+ cls destroy
+} -result {{} {} foo {} foo {}}
+
+test oo-41.1 {TIP 478: myclass command, including class morphing} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method count {} {
+ my variable c
+ incr c
+ }
+ method act {} {
+ myclass count
+ }
+ }
+ cls1 create x
+ lappend result [x act] [x act]
+ cls1 create y
+ lappend result [y act] [y act] [x act]
+ oo::class create cls2 {
+ superclass cls1
+ self method count {} {
+ my variable d
+ expr {1.0 * [incr d]}
+ }
+ }
+ oo::objdefine x {class cls2}
+ lappend result [x act] [y act] [x act] [y act]
+} -cleanup {
+ parent destroy
+} -result {1 2 3 4 5 1.0 6 2.0 7}
+test oo-41.2 {TIP 478: myclass command cleanup} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method hi {} {
+ return "this is [self]"
+ }
+ method hi {} {
+ return "this is [self]"
+ }
+ }
+ cls1 create x
+ rename [info object namespace x]::my foo
+ rename [info object namespace x]::myclass bar
+ lappend result [cls1 hi] [x hi] [foo hi] [bar hi]
+ x destroy
+ lappend result [catch {foo hi}] [catch {bar hi}]
+} -cleanup {
+ parent destroy
+} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1}
+test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method Hi {} {
+ return "this is [self]"
+ }
+ forward poke myclass Hi
+ }
+ cls1 create x
+ lappend result [catch {cls1 Hi}] [x poke]
+} -cleanup {
+ parent destroy
+} -result {1 {this is ::cls1}}
+
+test oo-42.1 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object
+} {}
+test oo-42.2 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object -class
+} {}
+test oo-42.3 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::object -instance
+} ::oo::objdefine
+test oo-42.4 {TIP 524: definition namespace control: introspection} -body {
+ info class definitionnamespace oo::object -gorp
+} -returnCodes error -result {bad kind "-gorp": must be -class or -instance}
+test oo-42.5 {TIP 524: definition namespace control: introspection} -body {
+ info class definitionnamespace oo::object -class x
+} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"}
+test oo-42.6 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class
+} ::oo::define
+test oo-42.7 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class -class
+} ::oo::define
+test oo-42.8 {TIP 524: definition namespace control: introspection} {
+ info class definitionnamespace oo::class -instance
+} {}
+
+test oo-43.1 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ oo::class create foo {
+ superclass parent
+ self class foocls
+ }
+ oo::define foo {
+ sparkle
+ }
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.2 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain ::result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo {
+ superclass parent
+ lappend ::result [sparkle]
+ }
+ return $result
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.3 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain ::result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace -class foodef
+ }
+ foocls create foo {
+ superclass parent
+ lappend ::result [sparkle]
+ }
+ return $result
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.4 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace -instance foodef
+ }
+ foocls create foo {
+ sparkle
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {invalid command name "sparkle"}
+test oo-43.5 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ namespace delete foodef
+ foocls create foo {
+ sparkle
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+ catch {namespace delete foodef}
+} -result {invalid command name "sparkle"}
+test oo-43.6 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+ unset -nocomplain result
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+ namespace delete foodef
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ lappend result [catch {oo::define foo sparkle} msg] $msg
+} -cleanup {
+ parent destroy
+ catch {namespace delete foodef}
+} -result {0 ok 1 {invalid command name "sparkle"} 0 ok}
+test oo-43.7 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::define
+ proc sparkle {x} {return ok}
+ }
+ oo::class create foocls {
+ superclass oo::class parent
+ definitionnamespace foodef
+ }
+ foocls create foo {
+ superclass parent
+ }
+ oo::define foo spar gorp
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.8 {TIP 524: definition namespace control: semantics} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {
+ namespace path ::oo::objdefine
+ proc sparkle {} {return ok}
+ }
+ oo::class create foo {
+ superclass parent
+ definitionnamespace -instance foodef
+ }
+ oo::objdefine [foo new] {
+ method x y z
+ sparkle
+ }
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result ok
+test oo-43.9 {TIP 524: definition namespace control: syntax} -body {
+ oo::class create foo {
+ definitionnamespace -gorp foodef
+ }
+} -returnCodes error -result {bad kind "-gorp": must be -class or -instance}
+test oo-43.10 {TIP 524: definition namespace control: syntax} -body {
+ oo::class create foo {
+ definitionnamespace -class foodef x
+ }
+} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"}
+test oo-43.11 {TIP 524: definition namespace control: syntax} -setup {
+ catch {namespace delete ::no_such_ns}
+} -body {
+ oo::class create foo {
+ definitionnamespace -class ::no_such_ns
+ }
+} -returnCodes error -result {namespace "::no_such_ns" not found}
+test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {}
+ oo::class create foo {
+ superclass oo::class parent
+ }
+ list [info class definitionnamespace foo] \
+ [oo::define foo definitionnamespace foodef] \
+ [info class definitionnamespace foo] \
+ [oo::define foo definitionnamespace {}] \
+ [info class definitionnamespace foo]
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {{} {} ::foodef {} {}}
+test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup {
+ oo::class create parent
+ namespace eval foodef {}
+} -body {
+ namespace eval foodef {}
+ oo::class create foo {
+ superclass parent
+ }
+ list [info class definitionnamespace foo -instance] \
+ [oo::define foo definitionnamespace -instance foodef] \
+ [info class definitionnamespace foo -instance] \
+ [oo::define foo definitionnamespace -instance {}] \
+ [info class definitionnamespace foo -instance]
+} -cleanup {
+ parent destroy
+ namespace delete foodef
+} -result {{} {} ::foodef {} {}}
cleanupTests
return
# Local Variables:
-# MODE: Tcl
+# mode: tcl
# End:
generated by cgit v0.12 at 2024-11-16 08:10:09 (GMT)