Index: generic/xotcl.c =================================================================== diff -u -rfc6166907f061a71b8a5766441c32080b5cf34f1 -re4021ec17be539fb4d0e7547bd9e93cece90fd49 --- generic/xotcl.c (.../xotcl.c) (revision fc6166907f061a71b8a5766441c32080b5cf34f1) +++ generic/xotcl.c (.../xotcl.c) (revision e4021ec17be539fb4d0e7547bd9e93cece90fd49) @@ -684,7 +684,7 @@ } } - /*fprintf(stderr, "try unknown for %s, result so far is %d\n", objName, result);*/ + /*fprintf(stderr, "try __unknown for %s, result so far is %d\n", objName, result);*/ if (baseClass) { Tcl_Obj *methodObj, *nameObj = isAbsolutePath(objName) ? objPtr : NameInNamespaceObj(interp, objName, callingNameSpace(interp)); @@ -5849,6 +5849,47 @@ return checker; } +static int +DispatchUnknownMethod(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], + Tcl_Obj *methodObj, int flags) { + int result; + XOTclObject *object = (XOTclObject*)clientData; + + Tcl_Obj *unknownObj = XOTclMethodObj(interp, object, XO_o_unknown_idx); + + if (unknownObj && methodObj != unknownObj && (flags & XOTCL_CM_NO_UNKNOWN) == 0) { + /* + * back off and try unknown; + */ + ALLOC_ON_STACK(Tcl_Obj*, objc+2, tov); + + /*fprintf(stderr, "calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s objc %d\n", + objectName(object), ObjStr(methodObj), flags, XOTCL_CM_NO_UNKNOWN, + XOTclObjectIsClass(object), object, objectName(object), objc);*/ + + tov[0] = object->cmdName; + tov[1] = unknownObj; + if (objc>0) { + memcpy(tov+2, objv, sizeof(Tcl_Obj *)*(objc)); + } + /* + fprintf(stderr, "?? %s unknown %s\n", objectName(object), ObjStr(tov[2])); + */ + flags &= ~XOTCL_CM_NO_SHIFT; + result = ObjectDispatch(clientData, interp, objc+2, tov, flags | XOTCL_CM_NO_UNKNOWN); + FREE_ON_STACK(Tcl_Obj*, tov); + + } else { /* no unknown called */ + fprintf(stderr, "--- No unknown method Name %s objv[%d] %s\n", + ObjStr(methodObj), 1, ObjStr(objv[1])); + result = XOTclVarErrMsg(interp, objectName(object), + ": xxx unable to dispatch method '", + ObjStr(objv[1]), "'", (char *) NULL); + } + return result; +} + /* * MethodDispatch() calls an XOTcl method. It calls either a * Tcl-implemented method (via ProcMethodDispatch()) or a C-implemented @@ -5951,9 +5992,14 @@ goto obj_dispatch_ok; } } + + result = DispatchUnknownMethod(self, interp, + objc-1, objv+1, objv[1], XOTCL_CM_NO_OBJECT_METHOD); + /* result = XOTclVarErrMsg(interp, objectName(self), - ": unable to dispatch method '", + ": aaa unable to dispatch method '", methodName, "'", (char *) NULL); + */ obj_dispatch_ok:; /*result = ObjectDispatch(cp, interp, objc, objv, XOTCL_CM_DELGATE);*/ #endif @@ -5989,6 +6035,23 @@ return result; } +static int +DispatchDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + int result; + Tcl_Obj *methodObj = XOTclMethodObj(interp, (XOTclObject *)clientData, XO_o_defaultmethod_idx); + + if (methodObj) { + Tcl_Obj *tov[2]; + tov[0] = objv[0]; + tov[1] = methodObj; + result = ObjectDispatch(clientData, interp, 2, tov, XOTCL_CM_NO_UNKNOWN); + } else { + result = TCL_OK; + } + return result; +} + + XOTCLINLINE static int ObjectDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], int flags) { @@ -6122,7 +6185,7 @@ if (cmd == NULL) { /* do we have a object-specific proc? */ - if (object->nsPtr) { + if (object->nsPtr && (flags & XOTCL_CM_NO_OBJECT_METHOD) == 0) { cmd = FindMethod(object->nsPtr, methodName); /* fprintf(stderr, "lookup for proc in obj %p method %s nsPtr %p => %p\n", object, methodName, object->nsPtr, cmd);*/ @@ -6211,43 +6274,8 @@ if (result == TCL_OK) { /*fprintf(stderr, "after doCallProcCheck unknown == %d\n", unknown);*/ if (unknown) { - Tcl_Obj *unknownObj = XOTclMethodObj(interp, object, XO_o_unknown_idx); - - if (unknownObj == NULL || (flags & XOTCL_CM_NO_UNKNOWN)) { - result = XOTclVarErrMsg(interp, objectName(object), - ": unable to dispatch method '", - methodName, "'", (char *) NULL); - goto exit_dispatch; - } else if (methodObj != unknownObj) { - /* - * back off and try unknown; - */ - XOTclObject *object = (XOTclObject*)clientData; - ALLOC_ON_STACK(Tcl_Obj*, objc+2, tov); - - /*fprintf(stderr, "calling unknown for %s %s, flgs=%02x,%02x isClass=%d %p %s objc %d shift %d\n", - objectName(object), methodName, flags, XOTCL_CM_NO_UNKNOWN, - XOTclObjectIsClass(object), object, objectName(object), objc, shift);*/ - - tov[0] = object->cmdName; - tov[1] = unknownObj; - if (objc-shift>0) { - memcpy(tov+2, objv+shift, sizeof(Tcl_Obj *)*(objc-shift)); - } - /* - fprintf(stderr, "?? %s unknown %s\n", objectName(object), ObjStr(tov[2])); - */ - flags &= ~XOTCL_CM_NO_SHIFT; - result = ObjectDispatch(clientData, interp, objc+2-shift, tov, flags | XOTCL_CM_NO_UNKNOWN); - FREE_ON_STACK(Tcl_Obj*, tov); - - } else { /* unknown failed */ - result = XOTclVarErrMsg(interp, objectName(object), - ": unable to dispatch method '", - ObjStr(objv[shift+1]), "'", (char *) NULL); - goto exit_dispatch; - } - + result = DispatchUnknownMethod(clientData, interp, + objc-shift, objv+shift, methodObj, flags); } } /* be sure to reset unknown flag */ @@ -6272,23 +6300,6 @@ } -static int -DispatchDefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - int result; - Tcl_Obj *methodObj = XOTclMethodObj(interp, (XOTclObject *)clientData, XO_o_defaultmethod_idx); - - if (methodObj) { - Tcl_Obj *tov[2]; - tov[0] = objv[0]; - tov[1] = methodObj; - result = ObjectDispatch(clientData, interp, 2, tov, XOTCL_CM_NO_UNKNOWN); - } else { - result = TCL_OK; - } - return result; -} - - int XOTclObjDispatch(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { int result; Index: generic/xotclInt.h =================================================================== diff -u -r649c33f8bca87b389877c3e3c1b7eb8e1182c843 -re4021ec17be539fb4d0e7547bd9e93cece90fd49 --- generic/xotclInt.h (.../xotclInt.h) (revision 649c33f8bca87b389877c3e3c1b7eb8e1182c843) +++ generic/xotclInt.h (.../xotclInt.h) (revision e4021ec17be539fb4d0e7547bd9e93cece90fd49) @@ -248,6 +248,7 @@ #define XOTCL_CM_NO_UNKNOWN 1 #define XOTCL_CM_NO_SHIFT 2 #define XOTCL_CM_NO_PROTECT 4 +#define XOTCL_CM_NO_OBJECT_METHOD 4 #define XOTCL_CM_DELGATE 0x10 /* Index: library/nx/nx.tcl =================================================================== diff -u -rf6469e86b7e32aac206d3c6c8526c179a0fb9ffe -re4021ec17be539fb4d0e7547bd9e93cece90fd49 --- library/nx/nx.tcl (.../nx.tcl) (revision f6469e86b7e32aac206d3c6c8526c179a0fb9ffe) +++ library/nx/nx.tcl (.../nx.tcl) (revision e4021ec17be539fb4d0e7547bd9e93cece90fd49) @@ -717,6 +717,117 @@ Class create ::nx::EnsembleObject + ::nx::EnsembleObject eval { + # + # The EnsembleObjects are called typically with a "self" bound to + # the object, on which they are registered as methods. This way, + # only method registered on the object are resolved (ensemble + # methods). Only for the methods "unknown" and "defaultmethod", + # self is actually the ensemble object. These methods are + # maintenance methods. We have to be careful ... + # + # a) not to interfere between "maintenance methods" and "ensemble + # methods" within the maintenance methods. This is achieved + # via explicit dispatch commands in the maintenance methods. + # + # b) not to overload "maintenance methods" with "ensemble + # methods". This is achieved via the object-method-only policy + # (we cannot call "subcmd " when "subcmdName" is a + # method on EnsembleObject) and via a skip object-methods flag + # in nsf when calling e.g. "unknwown" (such that a subcmd + # "unknown" does not interfere with the method "unknown"). + # + :method subcmdName {} { + # + # Compute the name of a subcmd and the object, on which it is + # registed, give an Ensemble object. + # + set self [::nsf::current object] + set parent [::nsf::dispatch $self ::nsf::cmd::ObjectInfo2::parent] + set grandparent [::nsf::dispatch $parent ::nsf::cmd::ObjectInfo2::parent] + set tail [namespace tail $parent] + if {$tail eq "slot" && [::nsf::objectproperty $grandparent class]} { + set aliases [::nsf::dispatch $grandparent ::nsf::cmd::ClassInfo2::methods -methodtype alias] + foreach alias $aliases { + set def [::nsf::dispatch $grandparent ::nsf::cmd::ClassInfo2::method definition $alias] + if {[lindex $def end] eq $self} { + return [list name [lindex $def 2] regobj ] + } + } + } + return [list name [namespace tail $self] regobj $parent] + } + + :method methodPath {} { + # + # Compute the composite path of a given ensemble object, + # containing its parent ensemble objects. + # + set o [::nsf::current object] + array set "" [$o ::nsf::classes::nx::EnsembleObject::subcmdName] + set path $(name) + while {1} { + set o [::nsf::dispatch $o ::nsf::cmd::ObjectInfo2::parent] + if {![::nsf::objectproperty $o type ::nx::EnsembleObject]} break + array set "" [$o ::nsf::classes::nx::EnsembleObject::subcmdName] + set path "$(name) $path" + } + return [list regobj $(regobj) path $path] + } + + :method subMethods {} { + # + # Compute pairs of method names and ensemble (sub)objects + # contained in the current object. + # + set result [list] + set self [::nsf::current object] + set methods [lsort [::nsf::dispatch $self ::nsf::cmd::ObjectInfo2::methods]] + array set "" [$self ::nsf::classes::nx::EnsembleObject::subcmdName] + foreach m $methods { + set type [::nsf::dispatch $self ::nsf::cmd::ObjectInfo2::method type $m] + if {$type eq "object"} { + foreach {obj submethod} \ + [::nsf::dispatch ${self}::$m ::nsf::classes::nx::EnsembleObject::subMethods] { + lappend result $obj $submethod + } + } else { + lappend result $self $m + } + } + return $result + } + + # + # The methods "unknown" and "defaultmethod" are called internally + # + :method unknown {m args} { + set self [::nsf::current object] + #puts stderr "UNKNOWN [self] $args" + array set "" [$self ::nsf::classes::nx::EnsembleObject::methodPath] + set subcmds [lsort [::nsf::dispatch $self ::nsf::cmd::ObjectInfo2::methods]] + error "unable to dispatch method $(regobj) $(path) $m;\ + valid subcommands of [namespace tail $self]: $subcmds" + } + + :method defaultmethod {} { + #puts uplevel-method=[uplevel {nx::current method}]-[uplevel nx::self] + set self [current object] + set methods [lsort [::nsf::dispatch $self ::nsf::cmd::ObjectInfo2::methods]] + array set "" [$self ::nsf::classes::nx::EnsembleObject::subcmdName] + set pairs [$self ::nsf::classes::nx::EnsembleObject::subMethods] + foreach {obj m} $pairs { + array set "" [$obj ::nsf::classes::nx::EnsembleObject::methodPath] + set cmd [::nsf::dispatch $obj ::nsf::cmd::ObjectInfo2::method parametersyntax $m] + puts stderr "$(regobj) $(path) $m $cmd" + } + return $methods + } + + # end of EnsembleObject + } + + ######################## # Info definition ########################