merge core-8-branch

4 files changed, 122 insertions, 44 deletions

diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index c22399a..1a0bb43 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2496,7 +2496,12 @@ ClassMixinSet(
     Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
     Tcl_Size mixinc, i;
     Tcl_Obj **mixinv;
-    Class **mixins;
+    Class **mixins;		/* The references to the classes to actually
+				 * install. */
+    Tcl_HashTable uniqueCheck;	/* Note that this hash table is just used as a
+				 * set of class references; it has no payload
+				 * values and keys are always pointers. */
+    int isNew;
 
     if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2518,6 +2523,7 @@ ClassMixinSet(
     }
 
     mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
+    Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);
 
     for (i = 0; i < mixinc; i++) {
 	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
@@ -2526,6 +2532,13 @@ ClassMixinSet(
 	    i--;
 	    goto freeAndError;
 	}
+	(void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
+	if (!isNew) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "class should only be a direct mixin once", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
+	    goto freeAndError;
+	}
 	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		    "may not mix a class into itself", -1));
@@ -2535,10 +2548,12 @@ ClassMixinSet(
     }
 
     TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
+    Tcl_DeleteHashTable(&uniqueCheck);
     TclStackFree(interp, mixins);
     return TCL_OK;
 
   freeAndError:
+    Tcl_DeleteHashTable(&uniqueCheck);
     TclStackFree(interp, mixins);
     return TCL_ERROR;
 }
@@ -2946,10 +2961,14 @@ ObjMixinSet(
     Tcl_Obj *const *objv)
 {
     Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-    Tcl_Size i;
-    Tcl_Size mixinc;
+    Tcl_Size mixinc, i;
     Tcl_Obj **mixinv;
-    Class **mixins;
+    Class **mixins;		/* The references to the classes to actually
+				 * install. */
+    Tcl_HashTable uniqueCheck;	/* Note that this hash table is just used as a
+				 * set of class references; it has no payload
+				 * values and keys are always pointers. */
+    int isNew;
 
     if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2965,19 +2984,32 @@ ObjMixinSet(
     }
 
     mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
+    Tcl_InitHashTable(&uniqueCheck, TCL_ONE_WORD_KEYS);
 
     for (i = 0; i < mixinc; i++) {
 	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
 		"may only mix in classes");
 	if (mixins[i] == NULL) {
-	    TclStackFree(interp, mixins);
-	    return TCL_ERROR;
+	    goto freeAndError;
+	}
+	(void) Tcl_CreateHashEntry(&uniqueCheck, (void *) mixins[i], &isNew);
+	if (!isNew) {
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "class should only be a direct mixin once", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
+	    goto freeAndError;
 	}
     }
 
     TclOOObjectSetMixins(oPtr, mixinc, mixins);
     TclStackFree(interp, mixins);
+    Tcl_DeleteHashTable(&uniqueCheck);
     return TCL_OK;
+
+  freeAndError:
+    TclStackFree(interp, mixins);
+    Tcl_DeleteHashTable(&uniqueCheck);
+    return TCL_ERROR;
 }
 
 /*
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index ec9e9da..6823a26 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -3929,22 +3929,23 @@ test iocmd.readFile-1.3 "readFile procedure: syntax" -body {
 } -returnCodes error -result {bad mode "gorp2": must be binary or text}
 
 test iocmd.readFile-2.1 "readFile procedure: behaviour" -setup {
-    set f [makeFile readFile21.txt "File\nContents"]
+    set f [makeFile "File\nContents" readFile21.txt]
 } -body {
     readFile $f
 } -cleanup {
     removeFile $f
 } -result "File\nContents\n"
 test iocmd.readFile-2.2 "readFile procedure: behaviour" -setup {
-    set f [makeFile readFile22.txt "File\nContents"]
+    set f [makeFile "File\nContents" readFile22.txt]
 } -body {
     readFile $f text
 } -cleanup {
     removeFile $f
 } -result "File\nContents\n"
 test iocmd.readFile-2.3 "readFile procedure: behaviour" -setup {
-    set f [makeFile readFile23.bin ""]
+    set f [makeFile "" readFile23.bindata]
     apply {filename {
+	global BIN_DATA
 	set ff [open $filename wb]
 	puts -nonewline $ff $BIN_DATA
 	close $ff
@@ -3955,7 +3956,7 @@ test iocmd.readFile-2.3 "readFile procedure: behaviour" -setup {
     removeFile $f
 } -result {1 {0 1 2 3 4 26 27 13 10 0}}
 # Need to set up ahead of the test
-set f [makeFile readFile24.txt ""]
+set f [makeFile "" readFile24.txt]
 removeFile $f
 test iocmd.readFile-2.4 "readFile procedure: behaviour" -body {
     readFile $f
@@ -3974,7 +3975,7 @@ test iocmd.writeFile-1.3 "writeFile procedure: syntax" -body {
 } -returnCodes error -result {bad mode "gorp2": must be binary or text}
 
 test iocmd.writeFile-2.1 "readFile procedure: behaviour" -setup {
-    set f [makeFile writeFile21.txt ""]
+    set f [makeFile "" writeFile21.txt]
     removeFile $f
 } -body {
     list [writeFile $f "File\nContents\n"] [apply {filename {
@@ -3987,7 +3988,7 @@ test iocmd.writeFile-2.1 "readFile procedure: behaviour" -setup {
     removeFile $f
 } -result [list {} "File\nContents\n"]
 test iocmd.writeFile-2.2 "readFile procedure: behaviour" -setup {
-    set f [makeFile writeFile22.txt ""]
+    set f [makeFile "" writeFile22.txt]
     removeFile $f
 } -body {
     writeFile $f text "File\nContents\n"
@@ -4001,7 +4002,7 @@ test iocmd.writeFile-2.2 "readFile procedure: behaviour" -setup {
     removeFile $f
 } -result "File\nContents\n"
 test iocmd.writeFile-2.3 "readFile procedure: behaviour" -setup {
-    set f [makeFile writeFile23.txt ""]
+    set f [makeFile "" writeFile23.txt]
     removeFile $f
 } -body {
     writeFile $f binary $BIN_DATA
@@ -4025,7 +4026,7 @@ test iocmd.foreachLine-1.2 "foreachLine procedure: syntax" -returnCodes error -b
     foreachLine a b c d
 } -result {wrong # args: should be "foreachLine varName filename body"}
 test iocmd.foreachLine-1.3 "foreachLine procedure: basic errors" -setup {
-    set f [makeFile foreachLine13.txt ""]
+    set f [makeFile "" foreachLine13.txt]
 } -body {
     apply {filename {
 	array set b {1 1}
@@ -4034,7 +4035,7 @@ test iocmd.foreachLine-1.3 "foreachLine procedure: basic errors" -setup {
 } -cleanup {
     removeFile $f
 } -returnCodes error -result {can't set "line": variable is array}
-set f [makeFile foreachLine14.txt ""]
+set f [makeFile "" foreachLine14.txt]
 removeFile $f
 test iocmd.foreachLine-1.4 "foreachLine procedure: basic errors" -body {
     apply {filename {
@@ -4043,19 +4044,20 @@ test iocmd.foreachLine-1.4 "foreachLine procedure: basic errors" -body {
 } -returnCodes error -result "couldn't open \"$f\": no such file or directory"
 
 test iocmd.foreachLine-2.1 "foreachLine procedure: behaviour" -setup {
-    set f [makeFile foreachLine21.txt "a\nb\nc"]
+    set f [makeFile "a\nb\nc" foreachLine21.txt]
 } -body {
     apply {filename {
 	set lines {}
 	foreachLine var $filename {
 	    lappend lines $var
 	}
+	return $lines
     }} $f
 } -cleanup {
     removeFile $f
 } -result {a b c}
 test iocmd.foreachLine-2.2 "foreachLine procedure: behaviour" -setup {
-    set f [makeFile foreachLine22.txt "a\nbb\nc\ndd"]
+    set f [makeFile "a\nbb\nc\ndd" foreachLine22.txt]
 } -body {
     apply {filename {
 	set lines {}
@@ -4069,7 +4071,7 @@ test iocmd.foreachLine-2.2 "foreachLine procedure: behaviour" -setup {
     removeFile $f
 } -result {bb dd}
 test iocmd.foreachLine-2.3 "foreachLine procedure: behaviour" -setup {
-    set f [makeFile foreachLine23.txt "a\nbb\nccc\ndd\ne"]
+    set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine23.txt]
 } -body {
     apply {filename {
 	set lines {}
@@ -4083,7 +4085,7 @@ test iocmd.foreachLine-2.3 "foreachLine procedure: behaviour" -setup {
     removeFile $f
 } -result {a bb}
 test iocmd.foreachLine-2.4 "foreachLine procedure: behaviour" -setup {
-    set f [makeFile foreachLine24.txt "a\nbb\nccc\ndd\ne"]
+    set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine24.txt]
 } -body {
     apply {filename {
     	set lines {}
@@ -4099,7 +4101,7 @@ test iocmd.foreachLine-2.4 "foreachLine procedure: behaviour" -setup {
     removeFile $f
 } -result {ccc}
 test iocmd.foreachLine-2.5 "foreachLine procedure: behaviour" -setup {
-    set f [makeFile foreachLine25.txt "a\nbb\nccc\ndd\ne"]
+    set f [makeFile "a\nbb\nccc\ndd\ne" foreachLine25.txt]
 } -body {
     apply {filename {
 	set lines {}
diff --git a/tests/oo.test b/tests/oo.test
index 291060d..cf8b710 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1685,9 +1685,7 @@ test oo-11.5 {OO: cleanup} {
     return done
 } done
 
-test oo-11.6.1 {
-    OO: cleanup of when an class is mixed into itself
-} -constraints memory -body {
+test oo-11.6.1 {OO: cleanup of when an class is mixed into itself} -constraints memory -body {
     leaktest {
 	interp create interp1
 	oo::class create obj1
@@ -1695,13 +1693,8 @@ test oo-11.6.1 {
 	rename obj1 {}
 	interp delete interp1
     }
-} -result 0 -cleanup {
-}
-
-test oo-11.6.2 {
-    OO: cleanup ReleaseClassContents() where class is mixed into one of its
-    instances
-} -constraints memory -body {
+} -result 0
+test oo-11.6.2 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -constraints memory -body {
     leaktest {
 	interp create interp1
 	interp1 eval {
@@ -1712,13 +1705,8 @@ test oo-11.6.2 {
 	}
 	interp delete interp1
     }
-} -result 0 -cleanup {
-}
-
-test oo-11.6.3 {
-    OO: cleanup ReleaseClassContents() where class is mixed into one of its
-    instances
-} -constraints memory -body {
+} -result 0
+test oo-11.6.3 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -constraints memory -body {
     leaktest {
 	interp create interp1
 	interp1 eval {
@@ -1731,13 +1719,8 @@ test oo-11.6.3 {
 	}
 	interp delete interp1
     }
-} -result 0 -cleanup {
-}
-
-test oo-11.6.4 {
-    OO: cleanup ReleaseClassContents() where class is mixed into one of its
-    instances
-} -body {
+} -result 0
+test oo-11.6.4 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -body {
     oo::class create obj1
     ::oo::define obj1 {self mixin [self]}
 
@@ -2218,6 +2201,31 @@ test oo-14.8 {OO: class mixin order - Bug 1998221} -setup {
     }
     [cls new] test
 } -result {mix cls}
+test oo-14.9 {OO: class mixins must be unique in list} -setup {
+    oo::class create parent
+} -body {
+    oo::class create A {superclass parent}
+    oo::class create B {
+	superclass parent
+	mixin A
+    }
+    oo::define B mixin -append A
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {class should only be a direct mixin once}
+test oo-14.10 {OO: instance mixins must be unique in list} -setup {
+    oo::class create parent
+} -body {
+    oo::class create A {superclass parent}
+    oo::class create B {
+	superclass parent
+	constructor {} {oo::objdefine [self] mixin A}
+    }
+    B create obj
+    oo::objdefine obj {mixin -append A}
+} -returnCodes error -cleanup {
+    parent destroy
+} -result {class should only be a direct mixin once}
 
 test oo-15.1 {OO: object cloning} {
     oo::class create Aclass
@@ -4198,6 +4206,19 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
     rename $s {}
 }] -result \
     {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}
+test oo-33.5 {TIP 567: slots -appendifnew} -setup [SampleSlotSetup {
+    set s [SampleSlot new]
+}] -body {
+    list \
+	[$s -clear
+	 $s contents] \
+	[$s -append p q r
+	 $s contents] \
+	[$s -appendifnew q s r t p
+	 $s contents]
+} -cleanup [SampleSlotCleanup {
+    rename $s {}
+}] -result {{} {p q r} {p q r s t}}
 
 test oo-34.1 {TIP 380: slots - presence} -setup {
     set obj [oo::object new]
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
index f41c668..9e1de8f 100644
--- a/tests/ooUtil.test
+++ b/tests/ooUtil.test
@@ -527,6 +527,29 @@ test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
     parent destroy
 } -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}
 
+# Tests a very weird combination of things (with a key problem locus in
+# MixinClassDelegates) that TIP 567 fixes
+test ooUtil-8.1 {TIP 567: call oo::define twice from metaclass constructor} -setup {
+    oo::class create parent
+} -body {
+    ::oo::class create A {
+	superclass parent
+    }
+    ::oo::class create B {
+	superclass ::oo::class parent
+    	constructor {{definitionScript ""}} {
+	    next $definitionScript
+	    next {superclass ::A}
+	}
+    }
+    B create C {
+	superclass A
+    }
+    C create instance
+} -cleanup {
+    parent destroy
+} -result ::instance
+
 # Tests that verify issues detected with the tcllib version of the code
 test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
     oo::class create animal {}