Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch tip-516 Excluding Merge-Ins
This is equivalent to a diff from e891020c32 to 4c8cd0f799
2018-09-27
| ||
07:22 | Implementation of TIP 516: More OO Slot Operations Closed-Leaf check-in: 28f8e4372e user: dkf tags: core-8-branch-timeline-fix | |
07:20 | help Closed-Leaf check-in: 2d2e7d5f73 user: dkf tags: core-8-branch-timeline-fix | |
2018-09-11
| ||
15:39 | merge 8.7 check-in: 0c62aa4c94 user: dgp tags: dgp-string-insert | |
07:44 | Simplify the slot resolution protocol Closed-Leaf check-in: 4c8cd0f799 user: dkf tags: tip-516 | |
2018-09-10
| ||
08:33 | Tests and docs check-in: ede05afd63 user: dkf tags: tip-516 | |
2018-09-08
| ||
21:18 | Merge core-8-branch check-in: 4c53b5eb75 user: jan.nijtmans tags: tip-515 | |
12:52 | Implementation of TIP 516 check-in: 84cceab204 user: dkf tags: tip-516 | |
2018-09-07
| ||
22:23 | Merge 8.6 check-in: 4ccc3b6902 user: jan.nijtmans tags: core-8-branch | |
12:11 | merge 8.7 check-in: 792948e482 user: dgp tags: trunk | |
12:11 | merge 8.6 check-in: e891020c32 user: dgp tags: core-8-branch | |
12:04 | Added test for [631b4c45df]. check-in: 036c01e552 user: dgp tags: core-8-6-branch | |
12:02 | merge 8.6 (segfault fix) check-in: 0a8630528a user: sebres tags: core-8-branch | |
Changes to doc/define.n.
︙ | ︙ | |||
422 423 424 425 426 427 428 | \fBself call\fR). .VE TIP500 .SH "SLOTTED DEFINITIONS" Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot object, that is an instance of the class \fBoo::Slot\fR, which manages a list of values (class names, variable names, etc.) that comprises the contents of | | > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 | \fBself call\fR). .VE TIP500 .SH "SLOTTED DEFINITIONS" Some of the configurable definitions of a class or object are \fIslotted definitions\fR. This means that the configuration is implemented by a slot object, that is an instance of the class \fBoo::Slot\fR, which manages a list 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 This prepends the given \fImember\fR elements to the slot definition. .VE TIP516 .TP \fIslot\fR \fB\-remove\fR ?\fImember ...\fR? .VS TIP516 This removes the given \fImember\fR elements from the slot definition. .VE TIP516 .TP \fIslot\fR \fB\-set\fR ?\fImember ...\fR? . This replaces the slot definition with the given \fImember\fR elements. .PP A consequence of this is that any use of a slot's default operation where the first member argument begins with a hyphen will be an error. One of the above operations should be used explicitly in those circumstances. .SS "SLOT IMPLEMENTATION" Internally, slot objects also define a method \fB\-\-default\-operation\fR which is forwarded to the default operation of the slot (thus, for the class .QW \fBvariable\fR slot, this is forwarded to .QW "\fBmy \-append\fR" ), and these methods which provide the implementation interface: .TP \fIslot\fR \fBGet\fR . Returns a list that is the current contents of the slot, but does not modify the slot. This method must always be called from a stack frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR return an error unless it is called from outside a definition context or with the wrong number of arguments. .RS .PP .VS TIP516 The elements of the list should be fully resolved, if that is a meaningful concept to the slot. .VE TIP516 .RE .TP \fIslot\fR \fBResolve\fR \fIslotElement\fR .VS TIP516 Returns \fIslotElement\fR with a resolution operation applied to it, but does not modify the slot. For slots of simple strings, this is an operation that does nothing, whereas for slots of classes, this maps a class name to its fully-qualified class name. This method must always be called from a stack frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method \fIshould not\fR return an error unless it is called from outside a definition context or with the wrong number of arguments; unresolvable arguments should be returned as is (as not all slot operations strictly require that values are resolvable to work). .RS .PP Implementations \fIshould not\fR enforce uniqueness and ordering constraints in this method; that is the responsibility of the \fBSet\fR method. .RE .VE TIP516 .TP \fIslot\fR \fBSet \fIelementList\fR . Sets the contents of the slot to the list \fIelementList\fR and returns the empty string. This method must always be called from a stack frame created by a call to \fBoo::define\fR or \fBoo::objdefine\fR. This method may return an error if it rejects the change to the slot contents (e.g., because of invalid values) as well as if it is called from outside a definition context or with the wrong number of arguments. .RS .PP This method \fImay\fR reorder and filter the elements if this is necessary in order to satisfy the underlying constraints of the slot. (For example, slots of classes enforce a uniqueness constraint that places each element in the earliest location in the slot that it can.) .RE .PP The implementation of these methods is slot-dependent (and responsible for accessing the correct part of the class or object definition). Slots also have an unknown method handler to tie all these pieces together, and they hide their \fBdestroy\fR method so that it is not invoked inadvertently. It is \fIrecommended\fR that any user changes to the slot mechanism be restricted to defining new operations whose names start with a hyphen. .PP .VS TIP516 Most slot operations will initially \fBResolve\fR their argument list, combine it with the results of the \fBGet\fR method, and then \fBSet\fR the result. Some operations omit one or both of the first two steps; omitting the third would result in an idempotent read-only operation (but the standard mechanism for reading from slots is via \fBinfo class\fR and \fBinfo object\fR). .VE TIP516 .SH EXAMPLES This example demonstrates how to use both forms of the \fBoo::define\fR and \fBoo::objdefine\fR commands (they work in the same way), as well as illustrating four of the subcommands of them. .PP .CS oo::class create c |
︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
︙ | ︙ | |||
33 34 35 36 37 38 39 40 41 | * Some things that make it easier to declare a slot. */ struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; }; | > | | > > | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | * Some things that make it easier to declare a slot. */ struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; const Tcl_MethodType resolverType; }; #define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ setter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ resolver, NULL, NULL}} /* * Forward declarations. */ static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, |
︙ | ︙ | |||
105 106 107 108 109 110 111 112 113 114 115 116 117 | int objc, Tcl_Obj *const *objv); static int ObjVarsGet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. */ static const struct DeclaredSlot slots[] = { | > > > | | | | | | | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | int objc, Tcl_Obj *const *objv); static int ObjVarsGet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static int ResolveClass(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. */ static const struct DeclaredSlot slots[] = { SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass), SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass), SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; /* * How to build the in-namespace name of a private variable. This is a pattern * used with Tcl_ObjPrintf(). */ |
︙ | ︙ | |||
2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 | int TclOODefineSlots( Foundation *fPtr) { const struct DeclaredSlot *slotInfoPtr; Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; if (slotCls == NULL) { return TCL_ERROR; } Tcl_IncrRefCount(getName); Tcl_IncrRefCount(setName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, | > > | > > > > > | 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 | int TclOODefineSlots( Foundation *fPtr) { const struct DeclaredSlot *slotInfoPtr; Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; if (slotCls == NULL) { return TCL_ERROR; } Tcl_IncrRefCount(getName); Tcl_IncrRefCount(setName); Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); if (slotObject == NULL) { continue; } Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, &slotInfoPtr->getterType, NULL); Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); if (slotInfoPtr->resolverType.callProc) { Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, &slotInfoPtr->resolverType, NULL); } } Tcl_DecrRefCount(getName); Tcl_DecrRefCount(setName); Tcl_DecrRefCount(resolveName); return TCL_OK; } /* * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- |
︙ | ︙ | |||
2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 | if (IsPrivateDefine(interp)) { InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, oPtr->creationEpoch); } else { InstallStandardVariableMapping(&oPtr->variables, varc, varv); } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 | if (IsPrivateDefine(interp)) { InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, oPtr->creationEpoch); } else { InstallStandardVariableMapping(&oPtr->variables, varc, varv); } return TCL_OK; } /* * ---------------------------------------------------------------------- * * ResolveClass -- * * Implementation of the "Resolve" support method for some slots (those * that are slots around a list of classes). This resolves possible class * names to their fully-qualified names if possible. * * ---------------------------------------------------------------------- */ static int ResolveClass( ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { int idx = Tcl_ObjectContextSkippedArgs(context); Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Class *clsPtr; /* * Check if were called wrongly. The definition context isn't used... * except that GetClassInOuterContext() assumes that it is there. */ if (oPtr == NULL) { return TCL_ERROR; } else if (objc != idx + 1) { Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); return TCL_ERROR; } /* * Resolve the class if possible. If not, remove any resolution error and * return what we've got anyway as the failure might not be fatal overall. */ clsPtr = GetClassInOuterContext(interp, objv[idx], "USER SHOULD NOT SEE THIS MESSAGE"); if (clsPtr == NULL) { Tcl_ResetResult(interp); Tcl_SetObjResult(interp, objv[idx]); } else { Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); } return TCL_OK; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclOOScript.h.
︙ | ︙ | |||
143 144 145 146 147 148 149 | "\tdefine Slot {\n" "\t\tmethod Get {} {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" "\t\tmethod Set list {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\t\t}\n" | > > > | > > > > > > | > > > > > > > > > > > > > > | | 143 144 145 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 | "\tdefine Slot {\n" "\t\tmethod Get {} {\n" "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" "\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 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\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\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\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 {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\texport -set -append -clear -prepend -remove\n" "\t\tunexport unknown 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" |
︙ | ︙ |
Changes to generic/tclOOScript.tcl.
︙ | ︙ | |||
272 273 274 275 276 277 278 279 280 281 282 283 284 285 | method Set list { return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" } # ------------------------------------------------------------------ # # 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. # # ------------------------------------------------------------------ | > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > > > > | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 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 | method Set list { return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" } # ------------------------------------------------------------------ # # Slot Resolve -- # # Helper that lets a slot convert a list of arguments of a # particular type to their canonical forms. Defaults to doing # nothing (suitable for simple strings). # # ------------------------------------------------------------------ method Resolve list { return $list } # ------------------------------------------------------------------ # # 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 args { set my [namespace which my] set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] tailcall my Set $args } method -append 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 { 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 { 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 {args} { set def --default-operation if {[llength $args] == 0} { tailcall my $def } elseif {![string match -* [lindex $args 0]]} { tailcall my $def {*}$args } next {*}$args } # Set up what is exported and what isn't export -set -append -clear -prepend -remove unexport unknown 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 |
︙ | ︙ |
Changes to tests/oo.test.
︙ | ︙ | |||
9 10 11 12 13 14 15 | package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } | < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in # this test suite, interp creation and interp deletion are often used in # leaktests in order to leverage this sensitivity. testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { set lines [split [memory info] \n] return [lindex $lines 3 3] } |
︙ | ︙ | |||
3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 | } method Set {lst} { variable contents $lst variable ops lappend ops [info level] Set $lst return } } } append script0 \n$script } proc SampleSlotCleanup script { set script0 { | > > > > > | 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 | } method Set {lst} { variable contents $lst variable ops lappend ops [info level] Set $lst return } method Resolve {lst} { variable ops lappend ops [info level] Resolve $lst return $lst } } } append script0 \n$script } proc SampleSlotCleanup script { set script0 { |
︙ | ︙ | |||
3868 3869 3870 3871 3872 3873 3874 | test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} | | | | > > > > > > > > > > > > > > > > | 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 | test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -set d e f] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}} test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -prepend g h i] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -remove c a] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { list [$s x y] [$s contents] } -cleanup [SampleSlotCleanup { rename $s {} |
︙ | ︙ | |||
3907 3908 3909 3910 3911 3912 3913 | test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { oo::objdefine $s forward --default-operation my -set list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup [SampleSlotCleanup { rename $s {} | | | | 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 | test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { oo::objdefine $s forward --default-operation my -set list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup [SampleSlotCleanup { rename $s {} }] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}} test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { 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, -clear, -prepend, -remove, -set, contents or ops} 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] |
︙ | ︙ | |||
3946 3947 3948 3949 3950 3951 3952 | } {::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 | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 | } {::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 -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}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass } {{-append -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}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter } {{-append -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}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -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 { oo::class create 516a { superclass parent } oo::class create 516b { superclass parent } oo::class create 516c { superclass parent } } } -body { # Must find the right classes when making the mixin namespace eval 516test { oo::define 516a { mixin 516b 516c } } lappend result [info class mixin 516test::516a] # Must not remove class with just simple name match oo::define 516test::516a { mixin -remove 516b } lappend result [info class mixin 516test::516a] # Must remove class with resolved name match oo::define 516test::516a { mixin -remove 516test::516c } lappend result [info class mixin 516test::516a] # Must remove class with resolved name match even after renaming, but only # with the renamed name; it is a slot of classes, not strings! rename 516test::516b 516test::516d oo::define 516test::516a { mixin -remove 516test::516b } lappend result [info class mixin 516test::516a] oo::define 516test::516a { mixin -remove 516test::516d } lappend result [info class mixin 516test::516a] } -cleanup { parent destroy } -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { method eat {} {} } set result {} } -body { |
︙ | ︙ |