diff options
| -rw-r--r-- | generic/tclOOScript.h | 30 | ||||
| -rw-r--r-- | tests/oo.test | 9 | ||||
| -rw-r--r-- | tools/tclOOScript.tcl | 32 |
3 files changed, 50 insertions, 21 deletions
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 9782875..ed8d2dd 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -362,10 +362,17 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\tproc ReadOne {object my propertyName} {\n" "\t\t\tset props [info object properties $object -all -readable]\n" -"\t\t\tset prop [prefix match -message \"property\" -error [list\\\n" -"\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\ttry {\n" +"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n" +"\t\t\t} on error {msg} {\n" +"\t\t\t\tcatch {\n" +"\t\t\t\t\tset wps [info object properties $object -all -writable]\n" +"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n" +"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n" +"\t\t\t\t}\n" +"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n" +"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n" +"\t\t\t}\n" "\t\t\ttry {\n" "\t\t\t\tset value [$my <ReadProp$prop>]\n" "\t\t\t} on error {msg opt} {\n" @@ -386,10 +393,17 @@ static const char *tclOOSetupScript = "\t\tproc WriteMany {object my setterMap} {\n" "\t\t\tset props [info object properties $object -all -writable]\n" "\t\t\tforeach {prop value} $setterMap {\n" -"\t\t\t\tset prop [prefix match -message \"property\" -error [list\\\n" -"\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\ttry {\n" +"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n" +"\t\t\t\t} on error {msg} {\n" +"\t\t\t\t\tcatch {\n" +"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n" +"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n" +"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n" +"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n" +"\t\t\t\t}\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" diff --git a/tests/oo.test b/tests/oo.test index 3fce886..e869a3c 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -5773,7 +5773,7 @@ test oo-45.7 {TIP 558: properties: configurable class system} -setup { list [p configure -y ok] [catch {p configure -y} msg] $msg } -cleanup { parent destroy -} -result {{} 1 {bad property "-y": must be -x}} +} -result {{} 1 {property "-y" is write only}} test oo-45.8 {TIP 558: properties: configurable class system} -setup { oo::class create parent unset -nocomplain msg @@ -5790,7 +5790,7 @@ test oo-45.8 {TIP 558: properties: configurable class system} -setup { list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg } -cleanup { parent destroy -} -result {{-x 0 -y 123} 123 1 {bad property "-y": must be -x}} +} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}} test oo-46.1 {ITP 558: properties: declaration semantics} -setup { oo::class create parent @@ -5946,17 +5946,18 @@ test oo-46.11 {TIP 558: properties: declaration semantics} -setup { variable xy property x -kind readable -get {return $xy} property x -kind writable -set {set xy $value} - property y } 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 {bad property "-x": must be -y}} +} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}} test oo-46.12 {TIP 558: properties: declaration semantics} -setup { oo::class create parent } -body { diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 095a3ad..12288e4 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -4,7 +4,7 @@ # that the code can be definitely run even in safe interpreters; TclOO's # core setup is safe. # -# Copyright (c) 2012-2018 Donal K. Fellows +# Copyright (c) 2012-2019 Donal K. Fellows # Copyright (c) 2013 Andreas Kupries # Copyright (c) 2017 Gerald Lester # @@ -626,10 +626,17 @@ proc ReadOne {object my propertyName} { set props [info object properties $object -all -readable] - set prop [prefix match -message "property" -error [list\ - -level 2 -errorcode [list \ - TCL LOOKUP INDEX property $propertyName]] \ - $props $propertyName] + try { + set prop [prefix match -message "property" $props $propertyName] + } on error {msg} { + catch { + set wps [info object properties $object -all -writable] + set wprop [prefix match $wps $propertyName] + set msg "property \"$wprop\" is write only" + } + return -code error -level 2 -errorcode [list \ + TCL LOOKUP INDEX property $propertyName] $msg + } try { set value [$my <ReadProp$prop>] } on error {msg opt} { @@ -659,10 +666,17 @@ proc WriteMany {object my setterMap} { set props [info object properties $object -all -writable] foreach {prop value} $setterMap { - set prop [prefix match -message "property" -error [list\ - -level 2 -errorcode [list \ - TCL LOOKUP INDEX property $prop]] \ - $props $prop] + try { + set prop [prefix match -message "property" $props $prop] + } on error {msg} { + catch { + set rps [info object properties $object -all -readable] + set rprop [prefix match $rps $prop] + set msg "property \"$rprop\" is read only" + } + return -code error -level 2 -errorcode [list \ + TCL LOOKUP INDEX property $prop] $msg + } try { $my <WriteProp$prop> $value } on error {msg opt} { |