summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2022-09-19 11:14:50 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2022-09-19 11:14:50 (GMT)
commit2ef45b059387e0c4c82491bf2261678935f1ca53 (patch)
tree63a06efd9e66a504943f26aa30bb66ebfb11b08f /tests
parent58467a7afe9d9eb62bb1da4d29690223a3681c16 (diff)
parentf3b329dd2833e543a9d0d3cd7aa2102fd5744cd9 (diff)
downloadtcl-2ef45b059387e0c4c82491bf2261678935f1ca53.zip
tcl-2ef45b059387e0c4c82491bf2261678935f1ca53.tar.gz
tcl-2ef45b059387e0c4c82491bf2261678935f1ca53.tar.bz2
rebase to 8.7
Diffstat (limited to 'tests')
-rw-r--r--tests/oo.test24
-rw-r--r--tests/ooProp.test885
2 files changed, 897 insertions, 12 deletions
diff --git a/tests/oo.test b/tests/oo.test
index ff67cc1..291060d 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -376,7 +376,7 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
}] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
interp delete $fresh
-} -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}
+} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::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::configuresupport::configurable} {::oo::abstract ::oo::configurable ::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
@@ -2458,7 +2458,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, creationid, 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, properties, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
oo::class create meta { superclass oo::class }
[meta create instance1] create instance2
@@ -2677,7 +2677,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, definitionnamespace, 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, properties, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
oo::class create testClass
} -body {
@@ -4197,7 +4197,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, -prepend, -remove, -set, contents or ops}
+ {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]
@@ -4220,32 +4220,32 @@ test oo-34.1 {TIP 380: slots - presence} -setup {
} -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}
+} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::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 -prepend -remove -set} {Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
getMethods oo::define::mixin
-} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.5 {TIP 380: slots - presence} {
getMethods oo::define::superclass
-} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.6 {TIP 380: slots - presence} {
getMethods oo::define::variable
-} {{-append -clear -prepend -remove -set} {Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
getMethods oo::objdefine::filter
-} {{-append -clear -prepend -remove -set} {Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
getMethods oo::objdefine::mixin
-} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.9 {TIP 380: slots - presence} {
getMethods oo::objdefine::variable
-} {{-append -clear -prepend -remove -set} {Get Set}}
+} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.10 {TIP 516: slots - resolution} -setup {
oo::class create parent
set result {}
diff --git a/tests/ooProp.test b/tests/ooProp.test
new file mode 100644
index 0000000..fd77997
--- /dev/null
+++ b/tests/ooProp.test
@@ -0,0 +1,885 @@
+# This file contains a collection of tests for Tcl's built-in object system,
+# specifically the parts that support configurable properties on objects.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2019-2020 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 tcl::oo 1.0.3
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
+ namespace import -force ::tcltest::*
+}
+
+test ooProp-1.1 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::readableproperties -set a b c
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::readableproperties -set f e d
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::readableproperties -set a a a
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::readableproperties -set
+ lappend result [info class properties c] [info class properties c -writable]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
+test ooProp-1.2 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a b c
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set f e d
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a a a
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
+test ooProp-1.3 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::writableproperties -set a b c
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::writableproperties -set f e d
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::writableproperties -set a a a
+ lappend result [info class properties c] [info class properties c -writable]
+ oo::define c ::oo::configuresupport::writableproperties -set
+ lappend result [info class properties c] [info class properties c -writable]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
+test ooProp-1.4 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a b c
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set f e d
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a a a
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set
+ lappend result [info class properties c -all] [info class properties c -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
+test ooProp-1.5 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ oo::class create d {superclass c}
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a b c
+ oo::define d ::oo::configuresupport::readableproperties -set x y z
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set f e d
+ oo::define d ::oo::configuresupport::readableproperties -set r p q
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a a h
+ oo::define d ::oo::configuresupport::readableproperties -set g h g
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define d ::oo::configuresupport::readableproperties -set
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}}
+test ooProp-1.6 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ oo::class create d {superclass c}
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a b c
+ oo::define d ::oo::configuresupport::writableproperties -set x y z
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set f e d
+ oo::define d ::oo::configuresupport::writableproperties -set r p q
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a a h
+ oo::define d ::oo::configuresupport::writableproperties -set g h g
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+ oo::define d ::oo::configuresupport::writableproperties -set
+ lappend result [info class properties d -all] [info class properties d -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}}
+test ooProp-1.7 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ c create o
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set
+ lappend result [info object properties o] [info object properties o -writable]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}}
+test ooProp-1.8 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ c create o
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h
+ lappend result [info object properties o] [info object properties o -writable]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set
+ lappend result [info object properties o] [info object properties o -writable]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}}
+test ooProp-1.9 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ oo::class create d {superclass c}
+ d create o
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+ oo::define c ::oo::configuresupport::readableproperties -set a b
+ oo::define d ::oo::configuresupport::readableproperties -set c d
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+ oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {a b c d e f} {} {a b c d e f} {}}
+test ooProp-1.10 {TIP 558: properties: core support} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::class create c {superclass parent}
+ oo::class create d {superclass c}
+ d create o
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+ oo::define c ::oo::configuresupport::writableproperties -set a b
+ oo::define d ::oo::configuresupport::writableproperties -set c d
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+ oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e
+ lappend result [info object properties o -all] [info object properties o -writable -all]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {a b c d e f} {} {a b c d e f}}
+test ooProp-1.11 {TIP 558: properties: core support cache} -setup {
+ oo::class create parent
+ unset -nocomplain result
+} -body {
+ oo::class create m {
+ superclass parent
+ ::oo::configuresupport::readableproperties -set a
+ ::oo::configuresupport::writableproperties -set c
+ }
+ oo::class create c {
+ superclass parent
+ ::oo::configuresupport::readableproperties -set b
+ ::oo::configuresupport::writableproperties -set d
+ }
+ c create o
+ lappend result [info object properties o -all -readable] \
+ [info object properties o -all -writable]
+ oo::objdefine o mixin m
+ lappend result [info object properties o -all -readable] \
+ [info object properties o -all -writable]
+} -cleanup {
+ parent destroy
+} -result {b d {a b} {c d}}
+
+test ooProp-2.1 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ variable x y
+ method report {} {
+ lappend ::result "x=$x, y=$y"
+ }
+ }
+ set pt [Point new -x 3]
+ $pt report
+ $pt configure -y 4
+ $pt report
+ lappend result [$pt configure -x],[$pt configure -y] [$pt configure]
+} -cleanup {
+ parent destroy
+} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}}
+test ooProp-2.2 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ oo::configurable create 3DPoint {
+ superclass Point
+ property z
+ constructor args {
+ next -z 0 {*}$args
+ }
+ }
+ set pt [3DPoint new -x 3 -y 4 -z 5]
+ list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
+ [$pt configure]
+} -cleanup {
+ parent destroy
+} -result {3,4,5 {-x 3 -y 4 -z 5}}
+test ooProp-2.3 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ set pt [Point new -x 3 -y 4]
+ oo::objdefine $pt property z
+ $pt configure -z 5
+ list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
+ [$pt configure]
+} -cleanup {
+ parent destroy
+} -result {3,4,5 {-x 3 -y 4 -z 5}}
+test ooProp-2.4 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ [Point new] configure gorp
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property "gorp": must be -x or -y}
+test ooProp-2.5 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ oo::configurable create 3DPoint {
+ superclass Point
+ property z
+ constructor args {
+ next -z 0 {*}$args
+ }
+ }
+ [3DPoint new] configure gorp
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property "gorp": must be -x, -y, or -z}
+test ooProp-2.6 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ [Point create p] configure -x 1 -y
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {wrong # args: should be "::p configure ?-option value ...?"}
+test ooProp-2.7 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+ unset -nocomplain msg
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y -kind writable
+ constructor args {
+ my configure -x 0 -y 0 {*}$args
+ }
+ }
+ Point create p
+ list [p configure -y ok] [catch {p configure -y} msg] $msg
+} -cleanup {
+ parent destroy
+} -result {{} 1 {property "-y" is write only}}
+test ooProp-2.8 {TIP 558: properties: configurable class system} -setup {
+ oo::class create parent
+ unset -nocomplain msg
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x y -kind readable
+ constructor args {
+ my configure -x 0 {*}$args
+ variable y 123
+ }
+ }
+ Point create p
+ list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg
+} -cleanup {
+ parent destroy
+} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}}
+
+test ooProp-3.1 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ variable xyz
+ property x -get {
+ global result
+ lappend result "get"
+ return [lrepeat 3 $xyz]
+ } -set {
+ global result
+ lappend result [list set $value]
+ set xyz [expr {$value * 3}]
+ }
+ }
+ Point create pt
+ pt configure -x 5
+ lappend result >[pt configure -x]<
+} -cleanup {
+ parent destroy
+} -result {{set 5} get {>15 15 15<}}
+test ooProp-3.2 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+ unset -nocomplain result
+ set result {}
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ variable xyz
+ property x -get {
+ global result
+ lappend result "get"
+ return [lrepeat 3 $xyz]
+ } -set {
+ global result
+ lappend result [list set $value]
+ set xyz [expr {$value * 3}]
+ } y -kind readable -get {return $xyz}
+ }
+ Point create pt
+ pt configure -x 5
+ lappend result >[pt configure -x]< [pt configure -y]
+} -cleanup {
+ parent destroy
+} -result {{set 5} get {>15 15 15<} 15}
+test ooProp-3.3 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ variable xyz
+ property -x -get {return $xyz}
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "-x": must not begin with -}
+test ooProp-3.4 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property "x y"
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "x y": must be a simple word}
+test ooProp-3.5 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property ::x
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "::x": must not contain namespace separators}
+test ooProp-3.6 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x(
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "x(": must not contain parentheses}
+test ooProp-3.7 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x)
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad property name "x)": must not contain parentheses}
+test ooProp-3.8 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x -get
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {missing body to go with -get option}
+test ooProp-3.9 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x -set
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {missing body to go with -set option}
+test ooProp-3.10 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x -kind
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {missing kind value to go with -kind option}
+test ooProp-3.11 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {superclass parent}
+ oo::define Point {
+ property x -get {} -set
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {missing body to go with -set option}
+test ooProp-3.12 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {} -get {return ok}
+ }
+ [Point new] configure -x
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.13 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -kind gorp
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad kind "gorp": must be readable, readwrite, or writable}
+test ooProp-3.14 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -k reada -g {return ok}
+ }
+ [Point new] configure -x
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.15 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property {*}{
+ x -kind writable
+ y -get {return ok}
+ }
+ }
+ [Point new] configure -y
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.16 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+ unset -nocomplain msg
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ variable xy
+ property x -kind readable -get {return $xy}
+ property x -kind writable -set {set xy $value}
+ }
+ Point create pt
+ list [catch {
+ pt configure -x ok
+ } msg] $msg [catch {
+ pt configure -x
+ } msg] $msg [catch {
+ pt configure -y 1
+ } msg] $msg
+} -cleanup {
+ parent destroy
+} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}}
+test ooProp-3.17 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -code break}
+ }
+ while 1 {
+ [Point new] configure -x
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property getter for -x did a break}
+test ooProp-3.18 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -code break}
+ }
+ while 1 {
+ [Point new] configure
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property getter for -x did a break}
+test ooProp-3.19 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {error "boo"}
+ }
+ while 1 {
+ [Point new] configure -x
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result boo
+test ooProp-3.20 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {error "boo"}
+ }
+ while 1 {
+ [Point new] configure
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result boo
+test ooProp-3.21 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -code continue}
+ }
+ while 1 {
+ [Point new] configure -x
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property getter for -x did a continue}
+test ooProp-3.22 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -level 2 ok}
+ }
+ apply {{} {
+ [Point new] configure
+ return bad
+ }}
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.23 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -get {return -level 2 ok}
+ }
+ apply {{} {
+ [Point new] configure -x
+ return bad
+ }}
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.24 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -set {return -code break}
+ }
+ while 1 {
+ [Point new] configure -x gorp
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property setter for -x did a break}
+test ooProp-3.25 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -set {return -code continue}
+ }
+ while 1 {
+ [Point new] configure -x gorp
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {property setter for -x did a continue}
+test ooProp-3.26 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -set {error "boo"}
+ }
+ while 1 {
+ [Point new] configure -x gorp
+ break
+ }
+} -returnCodes error -cleanup {
+ parent destroy
+} -result boo
+test ooProp-3.27 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x -set {return -level 2 ok}
+ }
+ apply {{} {
+ [Point new] configure -x gorp
+ return bad
+ }}
+} -cleanup {
+ parent destroy
+} -result ok
+test ooProp-3.28 {TIP 558: properties: declaration semantics} -setup {
+ oo::class create parent
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ private property var
+ }
+ Point create pt
+ pt configure -var ok
+ pt configure -var
+} -cleanup {
+ parent destroy
+} -result ok
+
+test ooProp-4.1 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property -x}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad property name "-x": must not begin with -
+ while executing
+"property -x"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}}
+test ooProp-4.2 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -get}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {missing body to go with -get option
+ while executing
+"property x -get"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -get}"} {TCL WRONGARGS}}
+test ooProp-4.3 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -set}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {missing body to go with -set option
+ while executing
+"property x -set"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -set}"} {TCL WRONGARGS}}
+test ooProp-4.4 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -kind}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {missing kind value to go with -kind option
+ while executing
+"property x -kind"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -kind}"} {TCL WRONGARGS}}
+test ooProp-4.5 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -kind gorp}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad kind "gorp": must be readable, readwrite, or writable
+ while executing
+"property x -kind gorp"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}}
+test ooProp-4.6 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {superclass parent}
+ list [catch {oo::define Point {property x -gorp}} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad option "-gorp": must be -get, -kind, or -set
+ while executing
+"property x -gorp"
+ (in definition script for class "::Point" line 1)
+ invoked from within
+"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}}
+test ooProp-4.7 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x
+ }
+ Point create pt
+ list [catch {pt configure -gorp} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad property "-gorp": must be -x
+ while executing
+"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}}
+test ooProp-4.8 {TIP 558: properties: error details} -setup {
+ oo::class create parent
+ unset -nocomplain msg opt
+} -body {
+ oo::configurable create Point {
+ superclass parent
+ property x
+ }
+ Point create pt
+ list [catch {pt configure -gorp blarg} msg opt] \
+ [dict get $opt -errorinfo] [dict get $opt -errorcode]
+} -cleanup {
+ parent destroy
+} -result {1 {bad property "-gorp": must be -x
+ while executing
+"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}}
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End: