There are subtle cases where an append-if-new operation is really useful for a slot.

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 <cloned> {originObject} {\n"
+"\tdefine object method <cloned> -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 <cloned> {originObject} {\n"
+"\tdefine class method <cloned> -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 <cloned> {originObject} {\n"
+"\t\t\t\t\tmethod <cloned> -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 <cloned> {originObject} {
+    define object method <cloned> -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 <cloned> {originObject} {
+    define class method <cloned> -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 <cloned> {originObject} {
+		    method <cloned> -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]
 		}