From 6eb109c913cd2b43ad9298df8f9eaf9e66c75a77 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 30 Dec 2019 15:35:51 +0000
Subject: Even more tests, this time of the return-code semantics of property
getters and setters.
---
generic/tclOOScript.h | 49 +++++++++++++-
tests/oo.test | 174 +++++++++++++++++++++++++++++++++++++++++++++++---
tools/tclOOScript.tcl | 49 +++++++++++++-
3 files changed, 256 insertions(+), 16 deletions(-)
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 7a4a0bb..e8fd814 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -348,7 +348,21 @@ static const char *tclOOSetupScript =
"\t\tproc ReadAll {object my} {\n"
"\t\t\tset result {}\n"
"\t\t\tforeach prop [info object property $object -all -readable] {\n"
-"\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
+"\t\t\t\ttry {\n"
+"\t\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
+"\t\t\t\t} on error {msg opt} {\n"
+"\t\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on return {msg opt} {\n"
+"\t\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on break {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property getter for $prop did a break\"\n"
+"\t\t\t\t} on continue {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n"
+"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $result\n"
"\t\t}\n"
@@ -358,7 +372,22 @@ static const char *tclOOSetupScript =
"\t\t\t\t\t-level 2 -errorcode [list \\\n"
"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName]] \\\n"
"\t\t\t\t\t\t $props $propertyName]\n"
-"\t\t\treturn [$my <ReadProp$prop>]\n"
+"\t\t\ttry {\n"
+"\t\t\t\tset value [$my <ReadProp$prop>]\n"
+"\t\t\t} on error {msg opt} {\n"
+"\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t} on return {msg opt} {\n"
+"\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t} on break {} {\n"
+"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\"property getter for $prop did a break\"\n"
+"\t\t\t} on continue {} {\n"
+"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\"property getter for $prop did a continue\"\n"
+"\t\t\t}\n"
+"\t\t\treturn $value\n"
"\t\t}\n"
"\t\tproc WriteMany {object my setterMap} {\n"
"\t\t\tset props [info object property $object -all -writable]\n"
@@ -367,7 +396,21 @@ static const char *tclOOSetupScript =
"\t\t\t\t\t-level 2 -errorcode [list \\\n"
"\t\t\t\t\t\tTCL LOOKUP INDEX property $prop]] \\\n"
"\t\t\t\t\t\t\t $props $prop]\n"
-"\t\t\t\t$my <WriteProp$prop> $value\n"
+"\t\t\t\ttry {\n"
+"\t\t\t\t\t$my <WriteProp$prop> $value\n"
+"\t\t\t\t} on error {msg opt} {\n"
+"\t\t\t\t\tdict set opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on return {msg opt} {\n"
+"\t\t\t\t\tdict incr opt -level 2\n"
+"\t\t\t\t\treturn -options $opt $msg\n"
+"\t\t\t\t} on break {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property setter for $prop did a break\"\n"
+"\t\t\t\t} on continue {} {\n"
+"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
+"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n"
+"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn\n"
"\t\t}\n"
diff --git a/tests/oo.test b/tests/oo.test
index f86b33a..631c84d 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -5894,8 +5894,8 @@ test oo-46.6 {TIP 558: properties: declaration semantics} -setup {
test oo-46.7 {TIP 558: properties: declaration semantics} -setup {
oo::class create parent
} -body {
- oo::configurable create Point {superclass parent}
- oo::define Point {
+ oo::configurable create Point {
+ superclass parent
property x -get {} -get {return ok}
}
[Point new] configure -x
@@ -5905,8 +5905,8 @@ test oo-46.7 {TIP 558: properties: declaration semantics} -setup {
test oo-46.8 {TIP 558: properties: declaration semantics} -setup {
oo::class create parent
} -body {
- oo::configurable create Point {superclass parent}
- oo::define Point {
+ oo::configurable create Point {
+ superclass parent
property x -kind gorp
}
} -returnCodes error -cleanup {
@@ -5915,8 +5915,8 @@ test oo-46.8 {TIP 558: properties: declaration semantics} -setup {
test oo-46.9 {TIP 558: properties: declaration semantics} -setup {
oo::class create parent
} -body {
- oo::configurable create Point {superclass parent}
- oo::define Point {
+ oo::configurable create Point {
+ superclass parent
property x -k reada -g {return ok}
}
[Point new] configure -x
@@ -5926,8 +5926,8 @@ test oo-46.9 {TIP 558: properties: declaration semantics} -setup {
test oo-46.10 {TIP 558: properties: declaration semantics} -setup {
oo::class create parent
} -body {
- oo::configurable create Point {superclass parent}
- oo::define Point {
+ oo::configurable create Point {
+ superclass parent
property {*}{
x -kind writable
y -get {return ok}
@@ -5941,8 +5941,8 @@ test oo-46.11 {TIP 558: properties: declaration semantics} -setup {
oo::class create parent
unset -nocomplain msg
} -body {
- oo::configurable create Point {superclass parent}
- oo::define Point {
+ oo::configurable create Point {
+ superclass parent
variable xy
property x -kind readable -get {return $xy}
property x -kind writable -set {set xy $value}
@@ -5957,6 +5957,160 @@ test oo-46.11 {TIP 558: properties: declaration semantics} -setup {
} -cleanup {
parent destroy
} -result {0 {} 1 {bad property "-x": must be -y}}
+test oo-46.12 {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 oo-46.13 {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 oo-46.14 {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 oo-46.15 {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 oo-46.16 {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 oo-46.17 {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 oo-46.18 {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 oo-46.19 {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 oo-46.20 {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 oo-46.21 {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 oo-46.22 {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 oo-47.1 {TIP 558: properties: error details} -setup {
oo::class create parent
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 4dbc48c..56a7bf8 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -600,7 +600,21 @@
proc ReadAll {object my} {
set result {}
foreach prop [info object property $object -all -readable] {
- dict set result $prop [$my <ReadProp$prop>]
+ try {
+ dict set result $prop [$my <ReadProp$prop>]
+ } on error {msg opt} {
+ dict set opt -level 2
+ return -options $opt $msg
+ } on return {msg opt} {
+ dict incr opt -level 2
+ return -options $opt $msg
+ } on break {} {
+ return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
+ "property getter for $prop did a break"
+ } on continue {} {
+ return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
+ "property getter for $prop did a continue"
+ }
}
return $result
}
@@ -620,7 +634,22 @@
-level 2 -errorcode [list \
TCL LOOKUP INDEX property $propertyName]] \
$props $propertyName]
- return [$my <ReadProp$prop>]
+ try {
+ set value [$my <ReadProp$prop>]
+ } on error {msg opt} {
+ dict set opt -level 2
+ return -options $opt $msg
+ } on return {msg opt} {
+ dict incr opt -level 2
+ return -options $opt $msg
+ } on break {} {
+ return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
+ "property getter for $prop did a break"
+ } on continue {} {
+ return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
+ "property getter for $prop did a continue"
+ }
+ return $value
}
# ------------------------------------------------------------------
@@ -638,7 +667,21 @@
-level 2 -errorcode [list \
TCL LOOKUP INDEX property $prop]] \
$props $prop]
- $my <WriteProp$prop> $value
+ try {
+ $my <WriteProp$prop> $value
+ } on error {msg opt} {
+ dict set opt -level 2
+ return -options $opt $msg
+ } on return {msg opt} {
+ dict incr opt -level 2
+ return -options $opt $msg
+ } on break {} {
+ return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
+ "property setter for $prop did a break"
+ } on continue {} {
+ return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
+ "property setter for $prop did a continue"
+ }
}
return
}
--
cgit v0.12