summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclOODefineCmds.c42
-rw-r--r--tests/oo.test69
-rw-r--r--tests/ooUtil.test23
3 files changed, 105 insertions, 29 deletions
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 034c877..a88a27e 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2455,9 +2455,13 @@ ClassMixinSet(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- int mixinc, i;
+ int mixinc, i, isNew;
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. */
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2479,6 +2483,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],
@@ -2487,6 +2492,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));
@@ -2496,10 +2508,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;
}
@@ -2906,10 +2920,15 @@ ObjMixinSet(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
- int mixinc;
+ int mixinc, i, isNew;
Tcl_Obj **mixinv;
Class **mixins;
int i;
+ 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. */
if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -2925,19 +2944,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/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 {}
generated by cgit v0.12 at 2025-12-12 00:49:45 (GMT)