Index: TODO =================================================================== diff -u -r59e100d383b22ea1407f5e5c40e303f2c6bb9027 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- TODO (.../TODO) (revision 59e100d383b22ea1407f5e5c40e303f2c6bb9027) +++ TODO (.../TODO) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -3857,8 +3857,25 @@ - nsf.c: start all error messages with a lower case word for consistency and to follow closer to Tcl's conventions +- deacitivate for the time being allowmethoddispatch + (make it behave always like true) +- added instead new flag "perobjectdispatch" to make + behavior of ensembleobjects configurable. +- The behavior for keepcallerself is currently + only activated for the method-interface + for object dispatch, since otherwise the following + would be dangerous, since "o2 foo" would destroy o2 + nx::Object create o1 + nsf::object::property o1 keepcallerself true + nx::Object create o2 { + ::public method foo {} {o1 destroy} + } + o2 foo + ======================================================================== TODO: +- cleanup of allowmethoddispatch / changing it maybe into private handling + - corollary: for complete configurability of method dispatch, we would need as well a 3rd object-property: restrict-dispatch-to-object-methods Index: generic/nsf.c =================================================================== diff -u -r59e100d383b22ea1407f5e5c40e303f2c6bb9027 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- generic/nsf.c (.../nsf.c) (revision 59e100d383b22ea1407f5e5c40e303f2c6bb9027) +++ generic/nsf.c (.../nsf.c) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -9478,6 +9478,16 @@ return NsfPrintError(interp, "trying to dispatch deleted object via method '%s'", methodName); } + + if ((invokedObject->flags & NSF_PER_OBJECT_DISPATCH) == 0) { + /*fprintf(stderr, "invokedObject %p %s methodName %s: no perobjectdispatch\n", + invokedObject, ObjectName(invokedObject), methodName);*/ + + if (invokedObject->flags & NSF_KEEP_CALLER_SELF) { + invokedObject = callerSelf; + } + return NsfObjDispatch(invokedObject, interp, objc, objv); + } /* * Make sure, that the current call is marked as an ensemble call, both @@ -9663,6 +9673,16 @@ int result; /* + * Privide dtrace with calling info + */ + if (NSF_DTRACE_METHOD_ENTRY_ENABLED()) { + NSF_DTRACE_METHOD_ENTRY(ObjectName(object), + cscPtr->cl ? ClassName(cscPtr->cl) : ObjectName(object), + (char *)methodName, + objc-1, (Tcl_Obj **)objv+1); + } + + /* * In a first step, resolve the alias */ @@ -9704,13 +9724,6 @@ // TODO: dereference chain? } - if (NSF_DTRACE_METHOD_ENTRY_ENABLED()) { - NSF_DTRACE_METHOD_ENTRY(ObjectName(object), - cscPtr->cl ? ClassName(cscPtr->cl) : ObjectName(object), - (char *)methodName, - objc-1, (Tcl_Obj **)objv+1); - } - /*fprintf(stderr, "MethodDispatch method '%s' cmd %p %s clientData %p cp=%p objc=%d cscPtr %p csc->flags %.6x \n", methodName, cmd, Tcl_GetCommandName(interp, cmd), clientData, cp, objc, cscPtr, cscPtr->flags);*/ @@ -9762,7 +9775,9 @@ */ return result; - } else if (proc == NsfObjDispatch) { + } else if (proc == NsfObjDispatch + /*//&& ((o = NsfGetObjectFromCmdPtr(cmd)) && o->id == cmd && (o->flags & NSF_PER_OBJECT_DISPATCH))*/ + ) { assert(cp); return ObjectCmdMethodDispatch((NsfObject *)cp, interp, objc, objv, @@ -10042,6 +10057,7 @@ int result = TCL_OK, objflags, shift, frameType = NSF_CSC_TYPE_PLAIN; CONST char *methodName; + NsfObject *calledObject; NsfClass *cl = NULL; Tcl_Command cmd = NULL; Tcl_Obj *cmdName = object->cmdName, *methodObj; @@ -10286,7 +10302,7 @@ object, methodName, object->nsPtr, cmd, cmd ? ((Command *)cmd)->objProc : NULL);*/ if (cmd) { - NsfObject *o; + //NsfObject *o; /* * Reject call when @@ -10295,7 +10311,7 @@ */ if (((flags & (NSF_CM_LOCAL_METHOD|NSF_CM_IGNORE_PERMISSIONS)) == 0 && (Tcl_Command_flags(cmd) & NSF_CMD_CALL_PRIVATE_METHOD)) - || ((o = NsfGetObjectFromCmdPtr(cmd)) && o->id == cmd && (o->flags & NSF_ALLOW_METHOD_DISPATCH) == 0) + //|| ((o = NsfGetObjectFromCmdPtr(cmd)) && o->id == cmd && (o->flags & NSF_ALLOW_METHOD_DISPATCH) == 0) ) { cmd = NULL; } else { @@ -10376,7 +10392,25 @@ } } +#if 0 + if ((object->flags & NSF_KEEP_CALLER_SELF) && (flags & NSF_CSC_CALL_IS_ENSEMBLE) == 0) { + calledObject = GetSelfObj(interp); + if (calledObject == NULL) { + NsfShowStack(interp); + fprintf(stderr, "strange, callerObject is apparently null; stay at %p %s %s FLAGS %.6x\n", + object, ObjectName(object), methodName, flags); + calledObject = object; + } + fprintf(stderr, "NSF_KEEP_CALLER_SELF %p %s calledObject %p %s\n", + object, ObjectName(object), calledObject, ObjectName(calledObject)); + } else { + calledObject = object; + } +#else + calledObject = object; +#endif + /* * If we have a command, check the permissions, unless * NSF_CM_IGNORE_PERMISSIONS is set. Note, that NSF_CM_IGNORE_PERMISSIONS is @@ -10426,7 +10460,7 @@ * We found the method to dispatch. */ cscPtr = CscAlloc(interp, &csc, cmd); - CscInit(cscPtr, object, cl, cmd, frameType, flags, methodName); + CscInit(cscPtr, calledObject, cl, cmd, frameType, flags, methodName); if (unlikely(cscPtr->frameType == NSF_CSC_TYPE_ACTIVE_FILTER)) { /* run filters is not NRE enabled */ @@ -17599,10 +17633,12 @@ * Treat aliased object dispatch different from direct object * dispatches. */ +#if 0 if (cmd == origCmd && (childObject->flags & NSF_ALLOW_METHOD_DISPATCH ) == 0) { /*fprintf(stderr, "no method dispatch allowed on child %s\n", ObjectName(childObject));*/ return TCL_OK; } +#endif } if (ProtectionMatches(withCallprotection, cmd) && methodTypeMatch) { @@ -17681,10 +17717,12 @@ * Treat aliased object dispatch different from direct object * dispatches. */ +#if 0 if (cmd == origCmd && (childObject->flags & NSF_ALLOW_METHOD_DISPATCH ) == 0) { /*fprintf(stderr, "no method dispatch allowed on child %s\n", ObjectName(childObject));*/ continue; } +#endif } @@ -19496,7 +19534,7 @@ /* cmd "object::property" NsfObjectPropertyCmd { {-argName "objectName" -required 1 -type object} - {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself|allowmethoddispatch" -required 1} + {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself|allowmethoddispatch|perobjectdispatch" -required 1} {-argName "value" -required 0 -type tclobj} } */ @@ -19513,6 +19551,7 @@ case ObjectpropertySlotcontainerIdx: flags = NSF_IS_SLOT_CONTAINER; break; case ObjectpropertyKeepcallerselfIdx: flags = NSF_KEEP_CALLER_SELF; allowSet = 1; break; case ObjectpropertyAllowmethoddispatchIdx: flags = NSF_ALLOW_METHOD_DISPATCH; allowSet = 1; break; + case ObjectpropertyPerobjectdispatchIdx: flags = NSF_PER_OBJECT_DISPATCH; allowSet = 1; break; } if (valueObj) { Index: generic/nsfAPI.decls =================================================================== diff -u -re7a27ff80df0f9c20be649e1ea1d0bc55f045739 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- generic/nsfAPI.decls (.../nsfAPI.decls) (revision e7a27ff80df0f9c20be649e1ea1d0bc55f045739) +++ generic/nsfAPI.decls (.../nsfAPI.decls) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -151,7 +151,7 @@ } {-nxdoc 1} cmd "object::property" NsfObjectPropertyCmd { {-argName "objectName" -required 1 -type object} - {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself|allowmethoddispatch" -required 1} + {-argName "objectproperty" -type "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself|allowmethoddispatch|perobjectdispatch" -required 1} {-argName "value" -required 0 -type tclobj} } {-nxdoc 1} cmd "object::qualify" NsfObjectQualifyCmd { Index: generic/nsfAPI.h =================================================================== diff -u -re7a27ff80df0f9c20be649e1ea1d0bc55f045739 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- generic/nsfAPI.h (.../nsfAPI.h) (revision e7a27ff80df0f9c20be649e1ea1d0bc55f045739) +++ generic/nsfAPI.h (.../nsfAPI.h) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -148,12 +148,12 @@ return result; } -enum ObjectpropertyIdx {ObjectpropertyNULL, ObjectpropertyInitializedIdx, ObjectpropertyClassIdx, ObjectpropertyRootmetaclassIdx, ObjectpropertyRootclassIdx, ObjectpropertySlotcontainerIdx, ObjectpropertyKeepcallerselfIdx, ObjectpropertyAllowmethoddispatchIdx}; +enum ObjectpropertyIdx {ObjectpropertyNULL, ObjectpropertyInitializedIdx, ObjectpropertyClassIdx, ObjectpropertyRootmetaclassIdx, ObjectpropertyRootclassIdx, ObjectpropertySlotcontainerIdx, ObjectpropertyKeepcallerselfIdx, ObjectpropertyAllowmethoddispatchIdx, ObjectpropertyPerobjectdispatchIdx}; static int ConvertToObjectproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, Nsf_Param CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { int index, result; - static CONST char *opts[] = {"initialized", "class", "rootmetaclass", "rootclass", "slotcontainer", "keepcallerself", "allowmethoddispatch", NULL}; + static CONST char *opts[] = {"initialized", "class", "rootmetaclass", "rootclass", "slotcontainer", "keepcallerself", "allowmethoddispatch", "perobjectdispatch", NULL}; (void)pPtr; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "objectproperty", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); @@ -201,7 +201,7 @@ {ConvertToRelationtype, "object-mixin|class-mixin|object-filter|class-filter|class|superclass|rootclass"}, {ConvertToSource, "all|application|baseclasses"}, {ConvertToConfigureoption, "debug|dtrace|filter|profile|softrecreate|objectsystems|keepinitcmd|checkresults|checkarguments"}, - {ConvertToObjectproperty, "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself|allowmethoddispatch"}, + {ConvertToObjectproperty, "initialized|class|rootmetaclass|rootclass|slotcontainer|keepcallerself|allowmethoddispatch|perobjectdispatch"}, {ConvertToAssertionsubcmd, "check|object-invar|class-invar"}, {NULL, NULL} }; Index: generic/nsfInt.h =================================================================== diff -u -r7413d266916a491ff674489513351c89987366d7 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- generic/nsfInt.h (.../nsfInt.h) (revision 7413d266916a491ff674489513351c89987366d7) +++ generic/nsfInt.h (.../nsfInt.h) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -381,7 +381,8 @@ #define NSF_IS_ROOT_CLASS 0x0100 #define NSF_IS_SLOT_CONTAINER 0x0200 #define NSF_KEEP_CALLER_SELF 0x0400 -#define NSF_ALLOW_METHOD_DISPATCH 0x0800 +#define NSF_ALLOW_METHOD_DISPATCH 0x10000 /* TODO: flag outside of range (intended)*/ +#define NSF_PER_OBJECT_DISPATCH 0x0800 /* deletion state */ #define NSF_DESTROY_CALLED_SUCCESS 0x1000 #define NSF_DURING_DELETE 0x2000 Index: library/nx/nx.tcl =================================================================== diff -u -re7a27ff80df0f9c20be649e1ea1d0bc55f045739 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- library/nx/nx.tcl (.../nx.tcl) (revision e7a27ff80df0f9c20be649e1ea1d0bc55f045739) +++ library/nx/nx.tcl (.../nx.tcl) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -482,6 +482,7 @@ :protected method init {} { ::nsf::object::property [self] keepcallerself true ::nsf::object::property [self] allowmethoddispatch true + ::nsf::object::property [self] perobjectdispatch true # object property "allowmethoddispatch" is just needed for # per-object ensembles and is set upon this creaton. } @@ -700,12 +701,14 @@ # Copy all info methods except the sub-objects to # ::nx::Class::slot::__info # + nsf::object::property ::nx::Class::slot::__info keepcallerself false foreach m [::nsf::directdispatch ::nx::Object::slot::__info ::nsf::methods::object::info::methods] { if {[::nsf::directdispatch ::nx::Object::slot::__info ::nsf::methods::object::info::method type $m] eq "object"} continue set definition [::nsf::directdispatch ::nx::Object::slot::__info ::nsf::methods::object::info::method definition $m] ::nx::Class::slot::__info {*}[lrange $definition 1 end] unset definition } + nsf::object::property ::nx::Class::slot::__info keepcallerself true Class eval { :alias "info lookup" ::nx::Object::slot::__info::lookup Index: library/xotcl/library/xotcl2.tcl =================================================================== diff -u -re7a27ff80df0f9c20be649e1ea1d0bc55f045739 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- library/xotcl/library/xotcl2.tcl (.../xotcl2.tcl) (revision e7a27ff80df0f9c20be649e1ea1d0bc55f045739) +++ library/xotcl/library/xotcl2.tcl (.../xotcl2.tcl) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -464,10 +464,13 @@ Object create ::xotcl::objectInfo Object create ::xotcl::classInfo ::nsf::object::property ::xotcl::objectInfo keepcallerself true - ::nsf::object::property ::xotcl::classInfo keepcallerself true + ::nsf::object::property ::xotcl::classInfo keepcallerself true ::nsf::object::property ::xotcl::objectInfo allowmethoddispatch true - ::nsf::object::property ::xotcl::classInfo allowmethoddispatch true + ::nsf::object::property ::xotcl::classInfo allowmethoddispatch true + ::nsf::object::property ::xotcl::objectInfo perobjectdispatch true + ::nsf::object::property ::xotcl::classInfo perobjectdispatch true + # note, we are using ::xotcl::infoError, defined below #Object instforward info -onerror ::nsf::infoError ::xotcl::objectInfo %1 {%@2 %self} #Class instforward info -onerror ::nsf::infoError ::xotcl::classInfo %1 {%@2 %self} Index: tests/destroy.test =================================================================== diff -u -r59e100d383b22ea1407f5e5c40e303f2c6bb9027 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- tests/destroy.test (.../destroy.test) (revision 59e100d383b22ea1407f5e5c40e303f2c6bb9027) +++ tests/destroy.test (.../destroy.test) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -433,13 +433,14 @@ Object create o Object create o2 # behave like an ensemble: aliased object has self of the caller - ::nsf::object::property o2 keepcallerself 1 + ::nsf::object::property o2 perobjectdispatch 1 ::nsf::method::alias o a o2 ? {o a} ::o2 "call object via alias" ? {o info method type a} alias ## the ensemble-object needs per-object methods o2 method info args {:info {*}$args} o2 method set args {:set {*}$args} + ::nsf::object::property o2 keepcallerself 1 ? {o a info vars} "" "call info on aliased object" ? {o set x 10} 10 "set variable on object" ? {o info vars} x "query vars" @@ -457,9 +458,12 @@ Object create o2 # The methods of the aliased object have their own self ::nsf::method::alias o a o2 + puts stderr ===5 ? {o a} ::o2 "call object via alias" + puts stderr ===6 + ? {o info method type a} alias - # In order to avoid recursive calles, we have to provide the + # In order to avoid recursive calls, we have to provide the # selector for the method definitions in nx::Object o2 method info args {: ::nsf::classes::nx::Object::info {*}$args} o2 method set args {: ::nsf::classes::nx::Object::set {*}$args} @@ -524,6 +528,8 @@ ::nsf::object::property o keepcallerself 1 ::nsf::object::property o3 keepcallerself 1 + ::nsf::object::property o perobjectdispatch 1 + ::nsf::object::property o3 perobjectdispatch 1 o alias a o3 C alias b o Index: tests/disposition.test =================================================================== diff -u -r59e100d383b22ea1407f5e5c40e303f2c6bb9027 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- tests/disposition.test (.../disposition.test) (revision 59e100d383b22ea1407f5e5c40e303f2c6bb9027) +++ tests/disposition.test (.../disposition.test) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -1162,6 +1162,7 @@ # ... at the called object level Object create ::callee { + ::nsf::object::property [self] perobjectdispatch true :public method foo {} { error [::nsf::current]-[::nsf::current methodpath] } @@ -1200,6 +1201,8 @@ nx::Test case dispo-object-targets { Object create obj + ::nsf::object::property obj perobjectdispatch true + Class create C Class create T { :public class method setObjectParams {spec} { @@ -1245,13 +1248,15 @@ } } + ::obj mixin UnknownHandler ? {[T create t] z uff} "CURRENT-::obj-DELEGATOR-::t-UNKNOWNMETHOD-uff-PATH-z" \ "Aliased dispatch to unknown method (custom unknown handler)" - + puts stderr ===2 set x [UnknownHandler create handledObj] + ::nsf::object::property handledObj perobjectdispatch true + set methods(ix) [::nsf::method::alias ::obj ix $x] - ? {[T create t] z ix baff} "CURRENT-$x-DELEGATOR-::obj-UNKNOWNMETHOD-baff-PATH-z ix" \ "Aliased dispatch to unknown method (custom unknown handler)" Index: tests/info-method.test =================================================================== diff -u -r59e100d383b22ea1407f5e5c40e303f2c6bb9027 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- tests/info-method.test (.../info-method.test) (revision 59e100d383b22ea1407f5e5c40e303f2c6bb9027) +++ tests/info-method.test (.../info-method.test) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -183,7 +183,9 @@ # # per default, we see just the alias # - ? {o info methods} "soAlias" + #? {o info methods} "soAlias" + #? {o info method type soAlias} "alias" + ? {o info methods} "soAlias sub" ? {o info method type soAlias} "alias" # Index: tests/submethods.test =================================================================== diff -u -r7413d266916a491ff674489513351c89987366d7 -r33d4fb2329d25b2a4e9ba05d312dfde2c73c3409 --- tests/submethods.test (.../submethods.test) (revision 7413d266916a491ff674489513351c89987366d7) +++ tests/submethods.test (.../submethods.test) (revision 33d4fb2329d25b2a4e9ba05d312dfde2c73c3409) @@ -332,11 +332,14 @@ ? {obj ifoo} ::ns1::obj::info # To some surprise, we can can still call info class! # This works, since we do here an "ensemble-next" - ? {obj info class} ::nx::Object + #? {obj info class} ::nx::Object + ? {obj info class} {::ns1::obj::info: unable to dispatch method 'class'} # The ensemble-next has in case of foo the leading colon on the # callstack (e.g. ":info"). Make sure that we can still call the # method via ensemle-next. - ? {obj foo} ::nx::Object + #? {obj foo} ::nx::Object + ? {obj foo} {::ns1::obj::info: unable to dispatch method 'class'} + } # @@ -565,33 +568,45 @@ ::nsf::object::property obj::child allowmethoddispatch false ? {obj link1 foo} {::obj::child} - ? {obj link2 foo} {::obj: unable to dispatch method 'child'} + #? {obj link2 foo} {::obj: unable to dispatch method 'child'} + ? {obj link2 foo} {::obj::child} ? {obj link3 foo} {::obj::child} ? {obj link4 foo} {::obj::child} ? {obj link5 foo} {::obj::child} - ? {lsort [obj info methods child]} {} - ? {lsort [obj info methods]} {link1 link2 link3 link4 link5} - ? {lsort [obj info lookup methods child]} {} - ? {lsort [obj info lookup methods child*]} {} + #? {lsort [obj info methods child]} {} + #? {lsort [obj info methods]} {link1 link2 link3 link4 link5} + #? {lsort [obj info lookup methods child]} {} + #? {lsort [obj info lookup methods child*]} {} + ? {lsort [obj info methods child]} {child} + ? {lsort [obj info methods]} {child link1 link2 link3 link4 link5} + ? {lsort [obj info lookup methods child]} {child} + ? {lsort [obj info lookup methods child*]} {child} # # turn on keepcallerself # ::nsf::object::property obj::child keepcallerself true ::nsf::object::property obj::child allowmethoddispatch false + ::nsf::object::property obj::child perobjectdispatch true ? {obj link1 foo} {::obj::child} - ? {obj link2 foo} {::obj: unable to dispatch method 'child'} + #? {obj link2 foo} {::obj: unable to dispatch method 'child'} + ? {obj link2 foo} {::obj} ? {obj link3 foo} {::obj::child} ? {obj link4 foo} {::obj} ? {obj link5 foo} {::obj::child} - ? {lsort [obj info methods child]} {} - ? {lsort [obj info methods]} {link1 link2 link3 link4 link5} - ? {lsort [obj info lookup methods child]} {} - ? {lsort [obj info lookup methods child*]} {} + #? {lsort [obj info methods child]} {} + #? {lsort [obj info methods]} {link1 link2 link3 link4 link5} + #? {lsort [obj info lookup methods child]} {} + #? {lsort [obj info lookup methods child*]} {} + ? {lsort [obj info methods child]} {child} + ? {lsort [obj info methods]} {child link1 link2 link3 link4 link5} + ? {lsort [obj info lookup methods child]} {child} + ? {lsort [obj info lookup methods child*]} {child} + # # turn on allowmethoddispatch #