diff options
| -rw-r--r-- | generic/tclOODefineCmds.c | 44 | ||||
| -rw-r--r-- | tests/ioCmd.test | 30 | ||||
| -rw-r--r-- | tests/oo.test | 69 | ||||
| -rw-r--r-- | tests/ooUtil.test | 23 |
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 {} |