diff options
| -rw-r--r-- | generic/tclOOScript.h | 49 | ||||
| -rw-r--r-- | tests/oo.test | 174 | ||||
| -rw-r--r-- | 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 } |