From 99145db40b9162cb8ac82c74d08da7f8f74eb911 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 15 Feb 2020 10:28:01 +0000 Subject: There are subtle cases where an append-if-new operation is really useful for a slot. --- doc/define.n | 6 ++++++ generic/tclOOScript.h | 43 ++++++++++++++++++++++++++----------------- tests/oo.test | 16 ++++++++-------- tools/tclOOScript.tcl | 45 +++++++++++++++++++++++++++------------------ 4 files changed, 67 insertions(+), 43 deletions(-) diff --git a/doc/define.n b/doc/define.n index 9046203..342b4c9 100644 --- a/doc/define.n +++ b/doc/define.n @@ -493,6 +493,12 @@ the slot: . This appends the given \fImember\fR elements to the slot definition. .TP +\fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR? +.VS TIP558 +This appends the given \fImember\fR elements to the slot definition if they +do not already exist. +.VE TIP558 +.TP \fIslot\fR \fB\-clear\fR . This sets the slot definition to the empty list. diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 2b61866..b3ff92f 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -98,9 +98,9 @@ static const char *tclOOSetupScript = "\t\t\tif {![info object isa class $d]} {\n" "\t\t\t\tcontinue\n" "\t\t\t}\n" -"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n" +"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n" "\t\t}\n" -"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n" +"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n" "\t}\n" "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" "\t\tset originDelegate [DelegateName $originObject]\n" @@ -141,34 +141,44 @@ static const char *tclOOSetupScript = "\t\t::namespace delete tmp\n" "\t}\n" "\tdefine Slot {\n" -"\t\tmethod Get {} {\n" +"\t\tmethod Get -unexport {} {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" -"\t\tmethod Set list {\n" +"\t\tmethod Set -unexport list {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" -"\t\tmethod Resolve list {\n" +"\t\tmethod Resolve -unexport list {\n" "\t\t\treturn $list\n" "\t\t}\n" -"\t\tmethod -set args {\n" +"\t\tmethod -set -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\ttailcall my Set $args\n" "\t\t}\n" -"\t\tmethod -append args {\n" +"\t\tmethod -append -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$current {*}$args]\n" "\t\t}\n" -"\t\tmethod -clear {} {tailcall my Set {}}\n" -"\t\tmethod -prepend args {\n" +"\t\tmethod -appendifnew -export args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\tset args [lmap a $args {\n" +"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n" +"\t\t\t\tif {$a in $current} continue\n" +"\t\t\t\tset a\n" +"\t\t\t}]\n" +"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" +"\t\t}\n" +"\t\tmethod -clear -export {} {tailcall my Set {}}\n" +"\t\tmethod -prepend -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\ttailcall my Set [list {*}$args {*}$current]\n" "\t\t}\n" -"\t\tmethod -remove args {\n" +"\t\tmethod -remove -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" @@ -177,7 +187,7 @@ static const char *tclOOSetupScript = "\t\t\t}]\n" "\t\t}\n" "\t\tforward --default-operation my -append\n" -"\t\tmethod unknown {args} {\n" +"\t\tmethod unknown -unexport {args} {\n" "\t\t\tset def --default-operation\n" "\t\t\tif {[llength $args] == 0} {\n" "\t\t\t\ttailcall my $def\n" @@ -186,13 +196,12 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t\tnext {*}$args\n" "\t\t}\n" -"\t\texport -set -append -clear -prepend -remove\n" -"\t\tunexport unknown destroy\n" +"\t\tunexport destroy\n" "\t}\n" "\tobjdefine define::superclass forward --default-operation my -set\n" "\tobjdefine define::mixin forward --default-operation my -set\n" "\tobjdefine objdefine::mixin forward --default-operation my -set\n" -"\tdefine object method {originObject} {\n" +"\tdefine object method -unexport {originObject} {\n" "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" "\t\t\tset args [info args $p]\n" "\t\t\tset idx -1\n" @@ -219,7 +228,7 @@ static const char *tclOOSetupScript = "\t\t\t}\n" "\t\t}\n" "\t}\n" -"\tdefine class method {originObject} {\n" +"\tdefine class method -unexport {originObject} {\n" "\t\tnext $originObject\n" "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" "\t}\n" @@ -235,7 +244,7 @@ static const char *tclOOSetupScript = "\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" "\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" "\t\t\t\t\t}\n" -"\t\t\t\t\tmethod {originObject} {\n" +"\t\t\t\t\tmethod -unexport {originObject} {\n" "\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" "\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" "\t\t\t\t\t}\n" @@ -439,7 +448,7 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\t::oo::class create configurable {\n" "\t\t\tprivate variable my\n" -"\t\t\tmethod configure args {\n" +"\t\t\tmethod configure -export args {\n" "\t\t\t\t::if {![::info exists my]} {\n" "\t\t\t\t\t::set my [::namespace which my]\n" "\t\t\t\t}\n" diff --git a/tests/oo.test b/tests/oo.test index c1907d5..0fa2559 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4163,7 +4163,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] @@ -4193,25 +4193,25 @@ proc getMethods obj { } 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/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index e918787..7355ad0 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -153,9 +153,9 @@ if {![info object isa class $d]} { continue } - define $delegate ::oo::define::superclass -append $d + define $delegate ::oo::define::superclass -appendifnew $d } - objdefine $class ::oo::objdefine::mixin -append $delegate + objdefine $class ::oo::objdefine::mixin -appendifnew $delegate } # ---------------------------------------------------------------------- @@ -257,7 +257,7 @@ # # ------------------------------------------------------------------ - method Get {} { + method Get -unexport {} { return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" } @@ -270,7 +270,7 @@ # # ------------------------------------------------------------------ - method Set list { + method Set -unexport list { return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" } @@ -284,7 +284,7 @@ # # ------------------------------------------------------------------ - method Resolve list { + method Resolve -unexport list { return $list } @@ -297,25 +297,35 @@ # # ------------------------------------------------------------------ - method -set args { + method -set -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] tailcall my Set $args } - method -append args { + method -append -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$current {*}$args] } - method -clear {} {tailcall my Set {}} - method -prepend args { + method -appendifnew -export args { + set my [namespace which my] + set current [uplevel 1 [list $my Get]] + set args [lmap a $args { + set a [uplevel 1 [list $my Resolve $a]] + if {$a in $current} continue + set a + }] + tailcall my Set [list {*}$current {*}$args] + } + method -clear -export {} {tailcall my Set {}} + method -prepend -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$args {*}$current] } - method -remove args { + method -remove -export args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] set current [uplevel 1 [list $my Get]] @@ -326,7 +336,7 @@ # Default handling forward --default-operation my -append - method unknown {args} { + method unknown -unexport {args} { set def --default-operation if {[llength $args] == 0} { tailcall my $def @@ -336,9 +346,8 @@ next {*}$args } - # Set up what is exported and what isn't - export -set -append -clear -prepend -remove - unexport unknown destroy + # Hide destroy + unexport destroy } # Set the default operation differently for these slots @@ -356,7 +365,7 @@ # # ---------------------------------------------------------------------- - define object method {originObject} { + define object method -unexport {originObject} { # Copy over the procedures from the original namespace foreach p [info procs [info object namespace $originObject]::*] { set args [info args $p] @@ -397,7 +406,7 @@ # # ---------------------------------------------------------------------- - define class method {originObject} { + define class method -unexport {originObject} { next $originObject # Rebuild the class inheritance delegation class ::oo::UpdateClassDelegatesAfterClone $originObject [self] @@ -424,7 +433,7 @@ ::return -code error -errorcode {TCLOO SINGLETON} \ "may not destroy a singleton object" } - method {originObject} { + method -unexport {originObject} { ::return -code error -errorcode {TCLOO SINGLETON} \ "may not clone a singleton object" } @@ -730,7 +739,7 @@ # Method for providing client access to the property mechanism. # Has a user-facing API similar to that of [chan configure]. # - method configure args { + method configure -export args { ::if {![::info exists my]} { ::set my [::namespace which my] } -- cgit v0.12