Index: generic/nsf.c =================================================================== diff -u -r551a41a1d6502070f966b5f0be2559cf3fe12804 -r1af8aba52df547aa435235e6ad307d7b97655de9 --- generic/nsf.c (.../nsf.c) (revision 551a41a1d6502070f966b5f0be2559cf3fe12804) +++ generic/nsf.c (.../nsf.c) (revision 1af8aba52df547aa435235e6ad307d7b97655de9) @@ -189,7 +189,7 @@ Tcl_Obj *obj, int flags); static int DispatchDestroyMethod(Tcl_Interp *interp, NsfObject *object, int flags); static int DispatchUnknownMethod(Tcl_Interp *interp, NsfObject *object, - int objc, Tcl_Obj *CONST objv[], NsfObject *delegator, + int objc, Tcl_Obj *CONST objv[], Tcl_Obj *callInfo, Tcl_Obj *methodObj, int flags); NSF_INLINE static int ObjectDispatch(ClientData clientData, Tcl_Interp *interp, int objc, @@ -8390,7 +8390,7 @@ } /*fprintf(stderr, "MethodDispatch method '%s' cmd %p cp=%p objc=%d cscPtr %p flags %.6x\n", - methodName, cmd, cp, objc, cscPtr, cscPtr->flags);*/ + methodName, cmd, cp, objc, cscPtr, cscPtr->flags);*/ assert(object->teardown); /* @@ -8554,8 +8554,18 @@ * we pass the object as first argument of the unknown * handler. */ - /*fprintf(stderr, "next calls DispatchUnknownMethod\n");*/ - result = DispatchUnknownMethod(interp, self, objc, objv, object, + fprintf(stderr, "next calls DispatchUnknownMethod\n"); + Tcl_Obj *callInfoObj = Tcl_NewListObj(0,NULL); + Tcl_ListObjAppendList(interp, + callInfoObj, + object->cmdName); + Tcl_Obj *methodPathObj = CallStackMethodPath(interp, + (Tcl_CallFrame *)framePtr, + Tcl_NewListObj(0, NULL)); + Tcl_ListObjAppendList(interp, callInfoObj, methodPathObj); + DECR_REF_COUNT(methodPathObj); + Tcl_ListObjAppendElement(interp,callInfoObj,objv[0]); + result = DispatchUnknownMethod(interp, self, objc-1, objv+1, callInfoObj, objv[1], NSF_CM_NO_OBJECT_METHOD|NSF_CSC_IMMEDIATE); } obj_dispatch_ok: @@ -8628,7 +8638,7 @@ assert (object->teardown); assert (cmd); - /* fprintf(stderr, "MethodDispatch method '%s.%s' objc %d flags %.6x call %d\n", + /*fprintf(stderr, "MethodDispatch method '%s.%s' objc %d flags %.6x call %d\n", ObjectName(object),methodName, objc, flags, call); */ cscPtr = CscAlloc(interp, &csc, cmd); @@ -8828,8 +8838,7 @@ assert((flags & (NSF_CSC_COPY_FLAGS & 0xFF00)) == 0); /*fprintf(stderr, "ObjectDispatch obj = %s objc = %d 0=%s methodName=%s\n", - ObjectName(object), objc, ObjStr(cmdObj), methodName);*/ - + object ? ObjectName(object) : NULL, objc, cmdObj ? ObjStr(cmdObj) : NULL, methodName);*/ objflags = object->flags; /* avoid stalling */ /* @@ -9253,59 +9262,68 @@ static int DispatchUnknownMethod(Tcl_Interp *interp, NsfObject *object, int objc, Tcl_Obj *CONST objv[], - NsfObject *delegator, Tcl_Obj *methodObj, int flags) { + Tcl_Obj *callInfoObj, Tcl_Obj *methodObj, int flags) { int result; Tcl_Obj *unknownObj = NsfMethodObj(object, NSF_o_unknown_idx); CONST char *methodName = MethodName(methodObj); /*fprintf(stderr, "compare unknownObj %p with methodObj %p '%s' %p %p %s -- %s\n", - unknownObj, methodObj, ObjStr(methodObj), delegator, - delegator?objv[1]:NULL, - delegator?ObjStr(objv[1]) : NULL, - methodName);*/ - + unknownObj, methodObj, ObjStr(methodObj), delegator, + delegator?objv[1]:NULL, + delegator?ObjStr(objv[1]) : NULL, + methodName);*/ + if (unknownObj && methodObj != unknownObj && (flags & NSF_CSC_CALL_NO_UNKNOWN) == 0) { /* * back off and try unknown; */ - int offset, mustCopy = *(ObjStr(methodObj)) == ':'; + int mustCopy = *(ObjStr(methodObj)) == ':'; - ALLOC_ON_STACK(Tcl_Obj*, objc+3, tov); - - /*fprintf(stderr, "calling unknown for %s %s, flgs=%.6x,%.6x/%.6x isClass=%d %p %s objc %d\n", - ObjectName(object), ObjStr(methodObj), flags, NSF_CM_NO_UNKNOWN,NSF_CSC_CALL_NO_UNKNOWN, - NsfObjectIsClass(object), object, ObjectName(object), objc);*/ - - tov[0] = object->cmdName; - tov[1] = unknownObj; - offset = 2; - if (delegator) { - tov[2] = delegator->cmdName; - offset ++; + if (callInfoObj == NULL) { + callInfoObj = Tcl_NewListObj(0,NULL); } - tov[offset] = mustCopy ? Tcl_NewStringObj(methodName, -1) : methodObj; - if (objc>1) { - memcpy(tov + offset + 1, objv + 1, sizeof(Tcl_Obj *) * (objc - 1)); - } + result = Tcl_ListObjAppendElement(interp, callInfoObj, + mustCopy ? Tcl_NewStringObj(methodName, -1) : methodObj); + INCR_REF_COUNT(callInfoObj); + if (result == TCL_OK) { + + ALLOC_ON_STACK(Tcl_Obj*, objc+3, tov); - flags &= ~NSF_CM_NO_SHIFT; + /*fprintf(stderr, "calling unknown for %s %s, flgs=%.6x,%.6x/%.6x isClass=%d %p %s objc %d\n", + ObjectName(object), ObjStr(methodObj), flags, NSF_CM_NO_UNKNOWN,NSF_CSC_CALL_NO_UNKNOWN, + NsfObjectIsClass(object), object, ObjectName(object), objc);*/ - /*fprintf(stderr, "call unknown via dispatch mustCopy %d delegator %p method %s (%s)\n", - mustCopy, delegator, ObjStr(tov[offset]), ObjStr(methodObj));*/ - - INCR_REF_COUNT(tov[offset]); - result = ObjectDispatch(object, interp, objc+offset, tov, flags|NSF_CM_NO_UNKNOWN); - DECR_REF_COUNT(tov[offset]); - - FREE_ON_STACK(Tcl_Obj*, tov); + tov[0] = object->cmdName; + tov[1] = unknownObj; + tov[2] = callInfoObj; + if (objc>1) { + memcpy(tov + 3, objv + 1, sizeof(Tcl_Obj *) * (objc - 1)); + } + + flags &= ~NSF_CM_NO_SHIFT; + + /*fprintf(stderr, "call unknown via dispatch mustCopy %d delegator %p method %s (%s)\n", + mustCopy, delegator, ObjStr(tov[offset]), ObjStr(methodObj));*/ + + result = ObjectDispatch(object, interp, objc+2, tov, flags|NSF_CM_NO_UNKNOWN); + FREE_ON_STACK(Tcl_Obj*, tov); + } + DECR_REF_COUNT(callInfoObj); } else { /* no unknown called, this is the built-in unknown handler */ - - /*fprintf(stderr, "--- default error message for unknown method '%s' " - "to be dispatched on %s, objv[%d] %s\n", - ObjStr(methodObj), ObjectName(object), 1, ObjStr(objv[1]));*/ - + Tcl_Obj *tailMethodObj; + if (objc > 1) { + int length; + if (Tcl_ListObjLength(interp, objv[1],&length) == TCL_OK && length > 0) { + Tcl_ListObjIndex(interp, objv[1], length - 1, &tailMethodObj); + } + } + + /* fprintf(stderr, "--- default error message for unknown method '%s' " + "to be dispatched on %s, objv[%d] %s /methodName %s\n", + ObjStr(methodObj), ObjectName(object), 1, ObjStr(objv[1]),methodName);*/ result = NsfPrintError(interp, "%s: unable to dispatch method '%s'", - ObjectName(object), /*methodName*/ objc > 1 ? MethodName(objv[1]) : methodName); + ObjectName(object), /*methodName*/ tailMethodObj ? + MethodName(tailMethodObj) : methodName); } return result; @@ -11946,8 +11964,8 @@ result = NextSearchMethod(object, interp, cscPtr, &cl, &methodName, &cmd, &isMixinEntry, &isFilterEntry, &endOfFilterChain, ¤tCmd); - /* fprintf(stderr, "NEXT search on %s.%s cl %p cmd %p endOfFilterChain %d result %d\n", - ObjectName(object), methodName, cl, cmd, endOfFilterChain, result);*/ + /*fprintf(stderr, "NEXT search on %s.%s cl %p cmd %p endOfFilterChain %d result %d\n", + ObjectName(object), methodName, cl, cmd, endOfFilterChain, result);*/ if (result != TCL_OK) { goto next_search_and_invoke_cleanup; @@ -16169,7 +16187,6 @@ assert(object->cmdName->refCount > 0); assert(object->activationCount >= 0); - #if defined(CHECK_ACTIVATION_COUNTS) if (object->activationCount > 0) { Tcl_CallFrame *framePtr; Index: generic/nsfDecls.h =================================================================== diff -u -r58e11ae3135406567181a97b8eac0d88e179a897 -r1af8aba52df547aa435235e6ad307d7b97655de9 --- generic/nsfDecls.h (.../nsfDecls.h) (revision 58e11ae3135406567181a97b8eac0d88e179a897) +++ generic/nsfDecls.h (.../nsfDecls.h) (revision 1af8aba52df547aa435235e6ad307d7b97655de9) @@ -182,7 +182,7 @@ struct NsfStubHooks *hooks; int (*nsf_Init) (Tcl_Interp *interp); /* 0 */ - VOID *reserved1; + void *reserved1; struct Nsf_Class * (*nsfIsClass) (Tcl_Interp *interp, ClientData cd); /* 2 */ struct Nsf_Object * (*nsfGetObject) (Tcl_Interp *interp, CONST char *name); /* 3 */ struct Nsf_Class * (*nsfGetClass) (Tcl_Interp *interp, CONST char *name); /* 4 */ Index: generic/nsfStack.c =================================================================== diff -u -r65ec5477000f631789c0809b8a832f45e1b634a4 -r1af8aba52df547aa435235e6ad307d7b97655de9 --- generic/nsfStack.c (.../nsfStack.c) (revision 65ec5477000f631789c0809b8a832f45e1b634a4) +++ generic/nsfStack.c (.../nsfStack.c) (revision 1af8aba52df547aa435235e6ad307d7b97655de9) @@ -589,20 +589,31 @@ /* * Append all ensemble names to the specified list obj */ - for (framePtr = Tcl_CallFrame_callerPtr(framePtr), elements = 1; + for (framePtr = Tcl_CallFrame_callerPtr(framePtr), elements = 0; Tcl_CallFrame_isProcCallFrame(framePtr) & (FRAME_IS_NSF_CMETHOD|FRAME_IS_NSF_METHOD); - framePtr = Tcl_CallFrame_callerPtr(framePtr), elements ++) { + framePtr = Tcl_CallFrame_callerPtr(framePtr)) { NsfCallStackContent *cscPtr = (NsfCallStackContent *)Tcl_CallFrame_clientData(framePtr); assert(cscPtr); - Tcl_ListObjAppendElement(interp, methodPathObj, - Tcl_NewStringObj(Tcl_GetCommandName(interp, cscPtr->cmdPtr), -1)); - if ((cscPtr->flags & NSF_CSC_TYPE_ENSEMBLE) == 0) break; + + /* + * Beware configure transparency: NsfOConfigureMethod() pushes a CMETHOD + * frame with a NULL cmdPtr in its callstack content, especially for + * providing callstack transparency for alias parameters. If not bypassing + * this special-purpose frame, we end up with erroreneous method path + * introspection: Method paths would be reported with preceding empty + * string elements! + */ + if (cscPtr->cmdPtr) { + Tcl_ListObjAppendElement(interp, methodPathObj, + Tcl_NewStringObj(Tcl_GetCommandName(interp, cscPtr->cmdPtr), -1)); + elements++; + } + if ((cscPtr->flags & NSF_CSC_TYPE_ENSEMBLE) == 0) break; } /* * The resulting list has reveresed order. If there are multiple * arguments, reverse the list to obtain the right order. */ - if (elements > 1) { int oc, i; Tcl_Obj **ov; Index: library/nx/nx.tcl =================================================================== diff -u -r551a41a1d6502070f966b5f0be2559cf3fe12804 -r1af8aba52df547aa435235e6ad307d7b97655de9 --- library/nx/nx.tcl (.../nx.tcl) (revision 551a41a1d6502070f966b5f0be2559cf3fe12804) +++ library/nx/nx.tcl (.../nx.tcl) (revision 1af8aba52df547aa435235e6ad307d7b97655de9) @@ -487,14 +487,16 @@ # in nsf when calling e.g. "unknown" (such that a subcmd # "unknown" does not interfere with the method "unknown"). # - :protected method unknown {obj m args} { - set path [current methodpath] - #puts stderr "+++ UNKNOWN obj $obj '$m' $args // path '[current methodpath]'" + :protected method unknown {callInfo args} { + set path [lrange $callInfo 1 end-1]; # set path [current methodpath] + set m [lindex $callInfo end] + set obj [lindex $callInfo 0] + # puts stderr "+++ UNKNOWN ARGS=[current args] obj $obj '$m' callInfo=$callInfo args=$args // path '[current methodpath]'" if {[catch {set valid [$obj ::nsf::methods::object::info::lookupmethods -path "$path *"]} errorMsg]} { set valid "" puts stderr "+++ UNKNOWN raises error $errorMsg" } - set ref "\"[lindex $args 0]\" of $obj $path" + set ref "\"$m\" of $obj $path" error "Unable to dispatch sub-method $ref; valid are: [join [lsort $valid] {, }]" } Index: tests/disposition.test =================================================================== diff -u -r551a41a1d6502070f966b5f0be2559cf3fe12804 -r1af8aba52df547aa435235e6ad307d7b97655de9 --- tests/disposition.test (.../disposition.test) (revision 551a41a1d6502070f966b5f0be2559cf3fe12804) +++ tests/disposition.test (.../disposition.test) (revision 1af8aba52df547aa435235e6ad307d7b97655de9) @@ -779,12 +779,207 @@ # "init" should be called only once ? {c1 eval {set :y}} 1 } -#puts stderr ===exit -#exit +nx::Test case dispo-configure-transparency { + Class create C { + :public class method setObjectParams {spec} { + set :objectparams $spec + ::nsf::invalidateobjectparameter [current] + } + :class method objectparameter {} { + if {[info exists :objectparams]} { + return ${:objectparams} + } + } + } + + ::proc foo {} { + error [::nsf::current]-[::nsf::current methodpath] + } + ::nsf::method::alias C FOO ::foo + ? {[C create c] FOO} "::c-FOO" + C setObjectParams [list [list FOO:alias,noarg ""]] + # UNPATCHED: + # ? {C create c} "::c-FOO" + C public method "show me" {} { + set :msg [::nsf::current]-[::nsf::current methodpath] + } + C setObjectParams [list -show:alias] + ? {[C create c -show me] eval {info exists :msg}} 1 + # UNPATCHED: + # ? {[C create c -show me] eval {set :msg}} "::c-{} show" + ? {[C create c -show me] eval {set :msg}} "::c-show" +} + +nx::Test case dispo-object-targets { + Object create obj + Class create C + Class create T { + :public class method setObjectParams {spec} { + set :objectparams $spec + ::nsf::invalidateobjectparameter [current] + } + :class method objectparameter {} { + if {[info exists :objectparams]} { + return ${:objectparams} + } + } + } + + # + # 1. Behavioural baseline: An alias method binding an object + # + set methods(z) [::nsf::method::alias T z ::obj] + ? {[T new] z} ::obj "Aliased dispatch to defaultmethod" + ? {[T new] z uff} "::obj: unable to dispatch method 'uff'" \ + "Aliased dispatch to unknown method (default unknown handler)" + + Class create UnknownHandler { + :method unknown {callInfo args} { + # + # callInfo is a Tcl list. For ensemble dispatches, it contains + # the complete message: delegator ; for + # ordinary dispatches, the list has a single element: + # + # methodpath [current methodpath] + # puts stderr "CALLINFO='$callInfo' args=$args" + switch [llength $callInfo] { + 1 { + error "UNKNOWNMETHOD-$callInfo" + } + default { + set delegator [lindex $callInfo 0] + set unknownMethod [lindex $callInfo end] + set path [lrange $callInfo 1 end-1] + error "CURRENT-[current]-DELEGATOR-$delegator-UNKNOWNMETHOD-$unknownMethod-PATH-$path" + } + } + } + } + + ::obj mixin UnknownHandler + ? {[T create t] z uff} "CURRENT-::obj-DELEGATOR-::t-UNKNOWNMETHOD-uff-PATH-z" \ + "Aliased dispatch to unknown method (custom unknown handler)" + + set x [UnknownHandler create handledObj] + set methods(ix) [::nsf::method::alias ::obj ix $x] + + ? {[T create t] z ix baff} "CURRENT-$x-DELEGATOR-::t-UNKNOWNMETHOD-baff-PATH-z ix" \ + "Aliased dispatch to unknown method (custom unknown handler)" + + # + # 2. Obj targets via alias disposition parameters + # + + # + # a) direct dispatch (non-aliased) with fully qualified selector (::*) + # + ::obj mixin {} + T setObjectParams x:alias,method=::obj + ? {T create t XXX} "::t: unable to dispatch method '::obj'" "FQ dispatch with default unknown handler" + + ::T mixin UnknownHandler + ? {T create t XXX} "UNKNOWNMETHOD-::obj" "FQ dispatch with custom unknown handler" + + # + # b) calls to the defaultmethod of the aliased object + # + UnknownHandler method defaultmethod {} { + set :defaultmethod 1 + } + ::obj mixin UnknownHandler + T setObjectParams [list [list z:alias,noarg ""]] + ? {T create t; ::obj eval {info exists :defaultmethod}} 1 \ + "Calling defaultmethod via alias+noarg combo with empty default" + T setObjectParams [list [list z:alias,noarg "XXX"]] + ? {T create t; ::obj eval {info exists :defaultmethod}} 1 \ + "Calling defaultmethod via alias+noarg non-empty with \ + default combo (default is not passed)" + # + # b) intermediary object aliases, non-fully qualified selector + # + + T setObjectParams [list [list z:alias,noarg ""]] + ? {T create tt} ::tt "sending the msg: tt->z()" + # + # ISSUE: positional objparam + alias + noarg -> what's the point? + # noarg & ?z? are irritating, ?z? should not be printed! + # + ? {T create t XXX} "Invalid argument 'XXX', maybe too many arguments; should be \"::t configure ?z?\"" + + ::obj mixin {} + T setObjectParams [list z:alias] + ? {T create tt YYY} "::obj: unable to dispatch method 'YYY'" "sending the msg: tt->z(::obj)->YYY()" + ::obj mixin UnknownHandler + ? {T create tt YYY} "CURRENT-::obj-DELEGATOR-::tt-UNKNOWNMETHOD-YYY-PATH-z" \ + "sending the msg: tt->z(::obj)->{}()" + + ::obj mixin {} + T setObjectParams [list -z:alias] + ? {T create tt -z YYY} "::obj: unable to dispatch method 'YYY'" "sending the msg: tt->z(::obj)->YYY()" + ::obj mixin UnknownHandler + ? {T create tt -z YYY} "CURRENT-::obj-DELEGATOR-::tt-UNKNOWNMETHOD-YYY-PATH-z" \ + "sending the msg: tt->z(::obj)->{}()" + + # + # [current methodpath] & empty selector strings: + # + + ::obj mixin {} + T setObjectParams [list z:alias] + ? {T create tt ""} "::obj: unable to dispatch method ''" "sending the msg: tt->z->{}()" + ::obj mixin UnknownHandler + ? {T create tt ""} "CURRENT-::obj-DELEGATOR-::tt-UNKNOWNMETHOD--PATH-z" "sending the msg: tt->z->{}()" + exit + T setObjectParams [list -z:alias] + ? {T create tt -z ""} ::tt "sending the msg: tt->z()" + + # + # ISSUE: Any direct dispatch with a FQ selector is forbidden, why? + # + + ::T mixin {} + ? [list [T create t] $methods(z) XXX] \ + "::t: unable to dispatch method '::nsf::classes::T::z'" + + # + # This it at least consistent :) + # + T setObjectParams x:alias,method=$methods(z) + ? {T create t XXX} "::t: unable to dispatch method '$methods(z)'" \ + "Non-object FQ selector with default unknown handler" + ::T mixin UnknownHandler + ? {T create t XXX} "UNKNOWNMETHOD-::nsf::classes::T::z" \ + "Non-object FQ selector with custom unknown handler" + + # + # A Tcl proc is allowed?! + # + proc ::baz {x} { + set :baz $x + } + T setObjectParams x:alias,method=::baz + ? {[T create t XXX] eval {info exists :baz}} 1 + ? {[T create t XXX] eval {set :baz}} XXX + + + # + # TBD: nested objects + # + + # + # TBD: object-system methods + # + +} + +# exit + # # check xotcl with residual args # + nx::Test case xotcl-residualargs { package req XOTcl Index: tests/forward.test =================================================================== diff -u -re02cb00ae815bd6f8561a6a03fceacc13fd91903 -r1af8aba52df547aa435235e6ad307d7b97655de9 --- tests/forward.test (.../forward.test) (revision e02cb00ae815bd6f8561a6a03fceacc13fd91903) +++ tests/forward.test (.../forward.test) (revision 1af8aba52df547aa435235e6ad307d7b97655de9) @@ -66,14 +66,15 @@ ########################################### Test case mixin-via-forward { Object create mixin { - :method unknown {m args} {return [concat [current] $m $args]} + :method unknown {m args} {puts stderr ARGS=[current args]; return [concat [current] $m $args]} } - + Object create obj { :public forward Mixin mixin %1 %self } ? {obj Mixin add M1} [list ::mixin add ::obj M1] + exit ? {catch {obj Mixin}} 1 obj public forward Mixin mixin "%1 {Getter Setter}" %self Index: tests/methods.test =================================================================== diff -u -r5972bd087afec6d23d1192d552a29c92e570d8a6 -r1af8aba52df547aa435235e6ad307d7b97655de9 --- tests/methods.test (.../methods.test) (revision 5972bd087afec6d23d1192d552a29c92e570d8a6) +++ tests/methods.test (.../methods.test) (revision 1af8aba52df547aa435235e6ad307d7b97655de9) @@ -188,6 +188,7 @@ ? {o :foo} "::o: methodname ':foo' must not start with a colon" ? {o eval :foo} "::o: unable to dispatch method 'foo'" } +exit Test case mixinguards { # define a Class C and mixin class M