Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch tip-567 Excluding Merge-Ins
This is equivalent to a diff from 5fcc28ca35 to 3eadffa22a
2022-08-31
| ||
10:05 | Merge 8.6 check-in: 0f133e4c3a user: jan.nijtmans tags: core-8-branch | |
09:55 | Merge 8.7 Closed-Leaf check-in: 3eadffa22a user: jan.nijtmans tags: tip-567 | |
09:07 | Merge 8.7 check-in: c8722e2db2 user: jan.nijtmans tags: trunk, main | |
2022-08-30
| ||
23:02 | Apply patch 0006 from [37108037b9]: Code cleanups to support CHERI check-in: 5fcc28ca35 user: jan.nijtmans tags: core-8-branch | |
22:30 | More code cleanup, inspired by [37108037b9] check-in: 949071abc3 user: jan.nijtmans tags: core-8-branch | |
2021-01-08
| ||
10:48 | Fix memory leak check-in: f4028b1cc3 user: jan.nijtmans tags: tip-567 | |
Changes to doc/define.n.
︙ | ︙ | |||
488 489 490 491 492 493 494 495 496 497 498 499 500 501 | of values (class names, variable names, etc.) that comprises the contents of the slot. The class defines five operations (as methods) that may be done on the slot: .TP \fIslot\fR \fB\-append\fR ?\fImember ...\fR? . This appends the given \fImember\fR elements to the slot definition. .TP \fIslot\fR \fB\-clear\fR . This sets the slot definition to the empty list. .TP \fIslot\fR \fB\-prepend\fR ?\fImember ...\fR? .VS TIP516 | > > > > > > | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 | of values (class names, variable names, etc.) that comprises the contents of the slot. The class defines five operations (as methods) that may be done on the slot: .TP \fIslot\fR \fB\-append\fR ?\fImember ...\fR? . This appends the given \fImember\fR elements to the slot definition. .TP \fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR? .VS TIP567 This appends the given \fImember\fR elements to the slot definition if they do not already exist in the slot. .VE TIP567 .TP \fIslot\fR \fB\-clear\fR . This sets the slot definition to the empty list. .TP \fIslot\fR \fB\-prepend\fR ?\fImember ...\fR? .VS TIP516 |
︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
︙ | ︙ | |||
2434 2435 2436 2437 2438 2439 2440 | TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); | | | > > > > > | 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 | TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int mixinc, i, isNew; Tcl_Obj **mixinv; 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, "mixinList"); return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); |
︙ | ︙ | |||
2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 | return TCL_ERROR; } else if (TclListObjGetElementsM(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc); for (i = 0; i < mixinc; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { i--; goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, mixins[i])) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); TclStackFree(interp, mixins); return TCL_OK; freeAndError: TclStackFree(interp, mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- | > > > > > > > > > > | 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 | return TCL_ERROR; } else if (TclListObjGetElementsM(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } 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) { 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)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); Tcl_DeleteHashTable(&uniqueCheck); TclStackFree(interp, mixins); return TCL_OK; freeAndError: TclStackFree(interp, mixins); Tcl_DeleteHashTable(&uniqueCheck); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- |
︙ | ︙ | |||
2836 2837 2838 2839 2840 2841 2842 | TclOOObjectSetFilters(oPtr, filterc, filterv); return TCL_OK; } /* * ---------------------------------------------------------------------- * | | | 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 | TclOOObjectSetFilters(oPtr, filterc, filterv); return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjMixinGet, ObjMixinSet -- * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2885 2886 2887 2888 2889 2890 2891 | TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); | | | > > > > | > > > > > | > > | > > > > > > | 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 | TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int mixinc, i, isNew; Tcl_Obj **mixinv; 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, "mixinList"); return TCL_ERROR; } else if (oPtr == NULL) { return TCL_ERROR; } objv += Tcl_ObjectContextSkippedArgs(context); if (TclListObjGetElementsM(interp, objv[0], &mixinc, &mixinv) != TCL_OK) { return TCL_ERROR; } 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) { 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; } /* * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- * |
︙ | ︙ |
Changes to generic/tclOOScript.h.
︙ | ︙ | |||
94 95 96 97 98 99 100 | "\t\t\treturn\n" "\t\t}\n" "\t\tforeach c [info class superclass $class] {\n" "\t\t\tset d [DelegateName $c]\n" "\t\t\tif {![info object isa class $d]} {\n" "\t\t\t\tcontinue\n" "\t\t\t}\n" | | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | "\t\t\treturn\n" "\t\t}\n" "\t\tforeach c [info class superclass $class] {\n" "\t\t\tset d [DelegateName $c]\n" "\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 -appendifnew $d\n" "\t\t}\n" "\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n" "\t}\n" "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" "\t\tset originDelegate [DelegateName $originObject]\n" "\t\tset targetDelegate [DelegateName $targetObject]\n" "\t\tif {\n" "\t\t\t[info object isa class $originDelegate]\n" "\t\t\t&& ![info object isa class $targetDelegate]\n" |
︙ | ︙ | |||
146 147 148 149 150 151 152 | "\t\t}\n" "\t\tmethod Set list {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" "\t\tmethod Resolve list {\n" "\t\t\treturn $list\n" "\t\t}\n" | | | > > > > > > > > > > > | | | | < | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | "\t\t}\n" "\t\tmethod Set list {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" "\t\tmethod Resolve list {\n" "\t\t\treturn $list\n" "\t\t}\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 -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 -appendifnew -export args {\n" "\t\t\tset my [namespace which my]\n" "\t\t\tset current [uplevel 1 [list $my Get]]\n" "\t\t\tforeach a $args {\n" "\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n" "\t\t\t\tif {$a ni $current} {\n" "\t\t\t\t\tlappend current $a\n" "\t\t\t\t}\n" "\t\t\t}\n" "\t\t\ttailcall my Set $current\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 -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 [lmap val $current {\n" "\t\t\t\tif {$val in $args} continue else {set val}\n" "\t\t\t}]\n" "\t\t}\n" "\t\tforward --default-operation my -append\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" "\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" "\t\t\t\ttailcall my $def {*}$args\n" "\t\t\t}\n" "\t\t\tnext {*}$args\n" "\t\t}\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" "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" "\t\t\tset args [info args $p]\n" |
︙ | ︙ |
Changes to tests/oo.test.
︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 | namespace delete $namespace }}} rename obj1 {} # No segmentation fault return done } done | < < | < < | < < | < < < | < < | < < < | < < | < < | 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 | namespace delete $namespace }}} rename obj1 {} # No segmentation fault return done } done test oo-11.6 {OO: cleanup of when an class is mixed into itself} memory { leaktest { interp create interp1 oo::class create obj1 ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} rename obj1 {} interp delete interp1 } } 0 test oo-11.7 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} memory { leaktest { interp create interp1 interp1 eval { oo::class create obj1 ::oo::copy obj1 obj2 rename obj2 {} rename obj1 {} } interp delete interp1 } } 0 test oo-11.8 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} memory { leaktest { interp create interp1 interp1 eval { oo::class create obj1 ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} ::oo::copy obj1 obj2 rename obj2 {} rename obj1 {} } interp delete interp1 } } 0 test oo-11.9 {OO: cleanup ReleaseClassContents() where class is mixed into one of its instances} -body { oo::class create obj1 ::oo::define obj1 {self mixin [self]} ::oo::copy obj1 obj2 ::oo::objdefine obj2 {mixin [self]} ::oo::copy obj2 obj3 |
︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 | oo::class create cls { superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } [cls new] test } -result {mix cls} test oo-15.1 {OO: object cloning} { oo::class create Aclass oo::define Aclass method test {} {lappend ::result [self object]->test} Aclass create Ainstance set result {} Ainstance test | > > > > > > > > > > > > > > > > > > > > > > > > > | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 | oo::class create cls { superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } [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 oo::define Aclass method test {} {lappend ::result [self object]->test} Aclass create Ainstance set result {} Ainstance test |
︙ | ︙ | |||
4193 4194 4195 4196 4197 4198 4199 | set s [SampleSlot new] }] -body { # Method names beginning with "-" are special to slots $s -grill q } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ | | > > > > > > > > > > > > > | 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 | set s [SampleSlot new] }] -body { # Method names beginning with "-" are special to slots $s -grill q } -returnCodes error -cleanup [SampleSlotCleanup { 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] set result {} } -body { oo::define oo::object { ::lappend ::result [::info object class filter] |
︙ | ︙ | |||
4223 4224 4225 4226 4227 4228 4229 | } {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} proc getMethods obj { list [lsort [info object methods $obj -all]] \ [lsort [info object methods $obj -private]] } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter | | | | | | | | | 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 | } {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} proc getMethods obj { list [lsort [info object methods $obj -all]] \ [lsort [info object methods $obj -private]] } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter } {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin } {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass } {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable } {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter } {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin } {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -appendifnew -clear -prepend -remove -set} {Get Set}} test oo-34.10 {TIP 516: slots - resolution} -setup { oo::class create parent set result {} oo::class create 516a { superclass parent } oo::class create 516b { superclass parent } oo::class create 516c { superclass parent } namespace eval 516test { |
︙ | ︙ |
Changes to tests/ooUtil.test.
︙ | ︙ | |||
522 523 524 525 526 527 528 529 530 531 532 533 534 535 | } } cls create o pqr list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg } -cleanup { parent destroy } -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} # 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 {} namespace eval ::ooutiltest { oo::class create pet { superclass animal } } | > > > > > > > > > > > > > > > > > > > > > > > | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 | } } cls create o pqr list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg } -cleanup { 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 {} namespace eval ::ooutiltest { oo::class create pet { superclass animal } } |
︙ | ︙ |
Changes to tools/tclOOScript.tcl.
︙ | ︙ | |||
149 150 151 152 153 154 155 | return } foreach c [info class superclass $class] { set d [DelegateName $c] if {![info object isa class $d]} { continue } | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | return } foreach c [info class superclass $class] { set d [DelegateName $c] if {![info object isa class $d]} { continue } define $delegate ::oo::define::superclass -appendifnew $d } objdefine $class ::oo::objdefine::mixin -appendifnew $delegate } # ---------------------------------------------------------------------- # # UpdateClassDelegatesAfterClone -- # # Support code that is like [MixinClassDelegates] except for when a |
︙ | ︙ | |||
293 294 295 296 297 298 299 | # Slot -set, -append, -clear, --default-operation -- # # Standard public slot operations. If a slot can't figure out # what method to call directly, it uses --default-operation. # # ------------------------------------------------------------------ | | | > > > > > > > > > > > | | | | | < | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 | # Slot -set, -append, -clear, --default-operation -- # # Standard public slot operations. If a slot can't figure out # what method to call directly, it uses --default-operation. # # ------------------------------------------------------------------ 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 -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 -appendifnew -export args { set my [namespace which my] set current [uplevel 1 [list $my Get]] foreach a $args { set a [uplevel 1 [list $my Resolve $a]] if {$a ni $current} { lappend current $a } } tailcall my Set $current } 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 -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 [lmap val $current { if {$val in $args} continue else {set val} }] } # Default handling forward --default-operation my -append method unknown -unexport {args} { set def --default-operation if {[llength $args] == 0} { tailcall my $def } elseif {![string match -* [lindex $args 0]]} { tailcall my $def {*}$args } next {*}$args } # Conceal destroy; want slots to persist, please unexport destroy } # Set the default operation differently for these slots objdefine define::superclass forward --default-operation my -set objdefine define::mixin forward --default-operation my -set objdefine objdefine::mixin forward --default-operation my -set |
︙ | ︙ |