diff options
| -rw-r--r-- | doc/define.n | 25 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 68 | ||||
| -rw-r--r-- | generic/tclOOScript.h | 9 | ||||
| -rw-r--r-- | generic/tclOOScript.tcl | 9 | ||||
| -rw-r--r-- | tests/oo.test | 10 |
5 files changed, 62 insertions, 59 deletions
diff --git a/doc/define.n b/doc/define.n index 1030096..883d5fa 100644 --- a/doc/define.n +++ b/doc/define.n @@ -477,22 +477,21 @@ concept to the slot. .VE TIP516 .RE .TP -\fIslot\fR \fBResolve\fR \fIelementList\fR +\fIslot\fR \fBResolve\fR \fIslotElement\fR .VS TIP516 -Returns a list that is the elements of \fIelementList\fR with a resolution -operation applied to each of them, but does not modify the slot. For slots of -simple strings, this is an operation that does nothing. For slots of classes, -this maps each 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. +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 reorder or filter elements in this operation; -uniqueness and ordering constraints should be enforced in the \fBSet\fR -method. This is because this method is not normally presented with the full -contents of the slot (except via the \fB\-set\fR slot operation). +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 diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index e4a30bb..b68cb0c 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -112,7 +112,7 @@ static int ObjVarsGet(ClientData clientData, static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static int ResolveClasses(ClientData clientData, +static int ResolveClass(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -122,11 +122,11 @@ static int ResolveClasses(ClientData clientData, static const struct DeclaredSlot slots[] = { SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClasses), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClasses), + 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, ResolveClasses), + 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}} }; @@ -2827,54 +2827,56 @@ ObjVarsSet( 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 -ResolveClasses( +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); - int cmdc, i, mustReset = 0; - Tcl_Obj **cmdv, **cmdv2; + Class *clsPtr; - if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { - Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, - "list"); - return TCL_ERROR; - } else if (oPtr == NULL) { + /* + * 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; - } - objv += Tcl_ObjectContextSkippedArgs(context); - if (Tcl_ListObjGetElements(interp, objv[0], &cmdc, - &cmdv) != TCL_OK) { + } else if (objc != idx + 1) { + Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); return TCL_ERROR; } - cmdv2 = TclStackAlloc(interp, sizeof(Tcl_Obj *) * cmdc); - /* - * Resolve each o + * 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. */ - for (i=0 ; i<cmdc ; i++) { - Class *clsPtr = GetClassInOuterContext(interp, cmdv[i], - "USER SHOULD NOT SEE THIS MESSAGE"); - if (clsPtr == NULL) { - cmdv2[i] = cmdv[i]; - mustReset = 1; - } else { - cmdv2[i] = TclOOObjectName(interp, clsPtr->thisPtr); - } - } - - if (mustReset) { + 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)); } - Tcl_SetObjResult(interp, Tcl_NewListObj(cmdc, cmdv2)); - TclStackFree(interp, cmdv2); + return TCL_OK; } diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index 5627bf8..2213ce3 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -151,25 +151,26 @@ static const char *tclOOSetupScript = "\t\t\treturn $list\n" "\t\t}\n" "\t\tmethod -set args {\n" -"\t\t\tset args [uplevel 1 [list [namespace which my] Resolve $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 [uplevel 1 [list $my Resolve $args]]\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 [uplevel 1 [list $my Resolve $args]]\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 [uplevel 1 [list $my Resolve $args]]\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" diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index 30af82a..a48eab5 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -298,25 +298,26 @@ # ------------------------------------------------------------------ method -set args { - set args [uplevel 1 [list [namespace which my] Resolve $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 [uplevel 1 [list $my Resolve $args]] + 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 [uplevel 1 [list $my Resolve $args]] + 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 [uplevel 1 [list $my Resolve $args]] + 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} diff --git a/tests/oo.test b/tests/oo.test index 1093f8d..033daf5 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3875,7 +3875,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {a b c g h i} {1 Resolve {g h i} 1 Get 1 Set {a b c g h i}}} +}] -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 { @@ -3883,7 +3883,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {d e f} {1 Resolve {d e f} 1 Set {d e f}}} +}] -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 { @@ -3891,7 +3891,7 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {} {d e f g h i} {1 Resolve {d e f} 1 Set {d e f} 1 Resolve {g h i} 1 Get 1 Set {d e f g h i}}} +}] -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 { @@ -3899,7 +3899,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {g h i a b c} {1 Resolve {g h i} 1 Get 1 Set {g h i a b c}}} +}] -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 { @@ -3907,7 +3907,7 @@ test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} b {1 Resolve {c a} 1 Get 1 Set b}} +}] -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] |