Index: TODO =================================================================== diff -u -r743d16c975ed13a6753d36eee38dc55395fcfed2 -r797decf0bf5d838727a50e35df060f6dfd55e65d --- TODO (.../TODO) (revision 743d16c975ed13a6753d36eee38dc55395fcfed2) +++ TODO (.../TODO) (revision 797decf0bf5d838727a50e35df060f6dfd55e65d) @@ -1134,17 +1134,29 @@ invoke "object as a method" - added option "-returns" to Object.method +- added option "-returns" to Class.method +- added subcmd to method/object method in nx +- delete class methods in freeAllXOTclObjectsAndClasses() explicitly + to handle potential double-deletes +- extended regression test for subcmds + TODO: - deeper analysis of "contains" - check feasability of "obj info filter guard name" etc. - unify SubcmdObj() and ParamCheckObj() handling? -- provide new tests for "TODO: changed xxxx" + +- subcmd + * handle sucmd for other method factories + * handle introspection for subcmd nicely + * handle absence of -create flag in resolve_method_path (for introspection) + * consider alternate method name/place for subcmds on classes + * provide new tests for "TODO: changed xxxx" + - add incompatiblity to migration guide Foo slot ints eval { set :incremental 1; :optimize} should become: Foo::slot::ints eval { set :incremental 1; :optimize} -- add option "-returns" to Class.method or remove - interfaces in documentation for slots (see for more details Index: generic/gentclAPI.decls =================================================================== diff -u -r743d16c975ed13a6753d36eee38dc55395fcfed2 -r797decf0bf5d838727a50e35df060f6dfd55e65d --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 743d16c975ed13a6753d36eee38dc55395fcfed2) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 797decf0bf5d838727a50e35df060f6dfd55e65d) @@ -558,11 +558,11 @@ {-argName "varname" -required 1} } -# temporary -# TODO: remove me -objectMethod vars XOTclOVarsMethod { - {-argName "pattern" -required 0} -} +# # temporary +# # TODO: remove me +# objectMethod vars XOTclOVarsMethod { +# {-argName "pattern" -required 0} +# } Index: generic/tclAPI.h =================================================================== diff -u -r743d16c975ed13a6753d36eee38dc55395fcfed2 -r797decf0bf5d838727a50e35df060f6dfd55e65d --- generic/tclAPI.h (.../tclAPI.h) (revision 743d16c975ed13a6753d36eee38dc55395fcfed2) +++ generic/tclAPI.h (.../tclAPI.h) (revision 797decf0bf5d838727a50e35df060f6dfd55e65d) @@ -189,7 +189,6 @@ static int XOTclOResidualargsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOUplevelMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOUpvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); -static int XOTclOVarsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOVolatileMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOVwaitMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclAliasCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -263,7 +262,6 @@ static int XOTclOResidualargsMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOUplevelMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOUpvarMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); -static int XOTclOVarsMethod(Tcl_Interp *interp, XOTclObject *obj, CONST char *pattern); static int XOTclOVolatileMethod(Tcl_Interp *interp, XOTclObject *obj); static int XOTclOVwaitMethod(Tcl_Interp *interp, XOTclObject *obj, CONST char *varname); static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, CONST char *methodName, int withNonleaf, int withObjscope, Tcl_Obj *cmdName); @@ -338,7 +336,6 @@ XOTclOResidualargsMethodIdx, XOTclOUplevelMethodIdx, XOTclOUpvarMethodIdx, - XOTclOVarsMethodIdx, XOTclOVolatileMethodIdx, XOTclOVwaitMethodIdx, XOTclAliasCmdIdx, @@ -1269,25 +1266,6 @@ } static int -XOTclOVarsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - XOTclObject *obj = (XOTclObject *)clientData; - if (!obj) return XOTclObjErrType(interp, objv[0], "Object", ""); - if (ArgumentParse(interp, objc, objv, obj, objv[0], - method_definitions[XOTclOVarsMethodIdx].paramDefs, - method_definitions[XOTclOVarsMethodIdx].nrParameters, - &pc) != TCL_OK) { - return TCL_ERROR; - } else { - CONST char *pattern = (CONST char *)pc.clientData[0]; - - parseContextRelease(&pc); - return XOTclOVarsMethod(interp, obj, pattern); - - } -} - -static int XOTclOVolatileMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; XOTclObject *obj = (XOTclObject *)clientData; @@ -2034,9 +2012,6 @@ {"::nsf::cmd::Object::upvar", XOTclOUpvarMethodStub, 1, { {"args", 0, 0, convertToNothing}} }, -{"::nsf::cmd::Object::vars", XOTclOVarsMethodStub, 1, { - {"pattern", 0, 0, convertToString}} -}, {"::nsf::cmd::Object::volatile", XOTclOVolatileMethodStub, 0, { } }, Index: generic/xotcl.c =================================================================== diff -u -r743d16c975ed13a6753d36eee38dc55395fcfed2 -r797decf0bf5d838727a50e35df060f6dfd55e65d --- generic/xotcl.c (.../xotcl.c) (revision 743d16c975ed13a6753d36eee38dc55395fcfed2) +++ generic/xotcl.c (.../xotcl.c) (revision 797decf0bf5d838727a50e35df060f6dfd55e65d) @@ -525,6 +525,7 @@ XOTclObjectRefCountDecr(object); if (object->refCount <= 0) { + /*fprintf(stderr, "XOTclCleanupObject %p refcount %d\n", object, object->refCount);*/ assert(object->refCount == 0); assert(object->flags & XOTCL_DELETED); @@ -5924,7 +5925,6 @@ * XOTCL_CM_DELGATE to use it. */ /*xxxx*/ - /*fprintf(stderr, "save self %p %s\n", object, objectName(object));*/ rst->delegatee = object; if (objc < 2) { result = DispatchDefaultMethod(cp, interp, objc, objv); @@ -5939,6 +5939,10 @@ #else XOTclObject *self = (XOTclObject *)cp; char *methodName; + /*fprintf(stderr, "save self %p %s object %p %s\n", + self, objectName(self), + object, objectName(object));*/ + if (self->nsPtr) { methodName = ObjStr(objv[1]); cmd = FindMethod(self->nsPtr, methodName); @@ -10359,7 +10363,25 @@ break; } } - +#if 0 + } else if (procPtr == XOTclObjDispatch) { + /* + Also some aliases come with procPtr == XOTclObjDispatch. In + order to dinstinguish between "object" and alias, we would + have to do the lookup for the entryObj in advance and alter + e.g. the procPtr. + */ + switch (subcmd) { + case InfomethodsubcmdTypeIdx: + Tcl_SetObjResult(interp, Tcl_NewStringObj("object", -1)); + break; + case InfomethodsubcmdDefinitionIdx: + { + Tcl_SetObjResult(interp, XOTclGlobalObjs[XOTE_EMPTY]); + break; + } + } +#endif } else { /* must be an alias */ switch (subcmd) { @@ -14650,7 +14672,11 @@ todo: remove debug line */ if (object->refCount != 1) { - fprintf(stderr, "*** have to fix refcount for obj %p refcount %d\n",object, object->refCount); + fprintf(stderr, "*** have to fix refcount for obj %p refcount %d",object, object->refCount); + if (object->refCount > 1) { + fprintf(stderr, " (name %s)",objectName(object)); + } + fprintf(stderr, "\n"); object->refCount = 1; } assert(object->activationCount == 0); @@ -14675,13 +14701,14 @@ /* * First delete all child commands of all objects, which are not * objects themselves. This will for example delete namespace - * imprted commands and objects and will resolve potential loops in + * imported commands and objects and will resolve potential loops in * the dependency graph. The result is a plain object/class tree. */ for (hPtr = Tcl_FirstHashEntry(commandNameTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { char *key = Tcl_GetHashKey(commandNameTable, hPtr); object = XOTclpGetObject(interp, key); + /* delete per-object methods */ if (object && object->nsPtr) { for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(object->nsPtr), &hSrch2); hPtr2; hPtr2 = Tcl_NextHashEntry(&hSrch2)) { @@ -14692,6 +14719,21 @@ } } } + + /* + * Delete class methods; these methods might have aliases (dependencies) to + * objects, which will resolved this way. + */ + if (XOTclObjectIsClass(object)) { + for (hPtr2 = Tcl_FirstHashEntry(Tcl_Namespace_cmdTable(((XOTclClass *)object)->nsPtr), &hSrch2); hPtr2; + hPtr2 = Tcl_NextHashEntry(&hSrch2)) { + Tcl_Command cmd = Tcl_GetHashValue(hPtr2); + if (cmd) { + Tcl_DeleteCommandFromToken(interp, cmd); + deleted ++; + } + } + } } /*fprintf(stderr, "deleted %d cmds\n", deleted);*/ @@ -14713,15 +14755,15 @@ object = XOTclpGetObject(interp, key); if (object && !XOTclObjectIsClass(object) && !ObjectHasChildren(interp, object)) { /*fprintf(stderr, " ... delete object %s %p, class=%s id %p\n", key, object, - className(object->cl), object->id);*/ + className(object->cl), object->id);*/ freeUnsetTraceVariable(interp, object); if (object->id) finalObjectDeletion(interp, object); Tcl_DeleteHashEntry(hPtr); deleted++; } } - /*fprintf(stderr, "deleted %d Objects\n", deleted);*/ + /* fprintf(stderr, "deleted %d Objects without dependencies\n", deleted);*/ if (deleted > 0) { continue; } Index: library/nx/nx.tcl =================================================================== diff -u -r743d16c975ed13a6753d36eee38dc55395fcfed2 -r797decf0bf5d838727a50e35df060f6dfd55e65d --- library/nx/nx.tcl (.../nx.tcl) (revision 743d16c975ed13a6753d36eee38dc55395fcfed2) +++ library/nx/nx.tcl (.../nx.tcl) (revision 797decf0bf5d838727a50e35df060f6dfd55e65d) @@ -68,6 +68,57 @@ ::nsf::methodproperty Class dealloc redefine-protected true ::nsf::methodproperty Class create redefine-protected true + ::nsf::method Object -per-object resolve_method_path { + -create:switch + -per-object:switch + -verbose:switch + object + path + } { + # TODO: handle -create (actually, its absence) + set methodName $path + if {[string first " " $path]} { + set methodName [lindex $path end] + foreach w [lrange $path 0 end-1] { + #puts stderr "check $object info methods $w => '[$object info methods -methodtype all $w]'" + set scope [expr {[nsf::objectproperty $object class] && !${per-object} ? "Class" : "Object"}] + if {[::nsf::cmd::${scope}Info::methods $object -methodtype all $w] eq ""} { + # + # Create dispatch object an accessor method (if wanted) + # + set o [Object create ${object}::$w] + if {$verbose} {puts stderr "... create object $o"} + if {$scope eq "Class"} { + # we are on a class, and have to create an alias to be + # accessible for objects + ::nsf::alias $object $w $o + if {$verbose} {puts stderr "... create alias $object $w $o"} + } + #puts stderr "... $object info methods $w => '[$object info methods -methodtype all $w]'" + set object $o + } else { + # + # The accessor method exists already, check, if it is + # appropriate for extending. + # + set type [::nsf::cmd::${scope}Info::method $object type $w] + set definition [::nsf::cmd::${scope}Info::method $object definition $w] + if {$scope eq "Class"} { + if {$type ne "alias"} {error "can't append to $type"} + if {$definition eq ""} {error "definition must not be empty"} + set object [lindex $definition end] + } else { + if {$type ne "alias"} {error "can't append to $type"} + if {$definition ne ""} {error "unexpected definition '$definition'"} + append object ::$w + } + } + } + #puts stderr "... final object $object method $methodName" + } + return [list object $object methodName $methodName] + } + # define method "method" for Class and Object # @method ::nx::Class#method @@ -100,7 +151,10 @@ set conditions [list] if {[info exists precondition]} {lappend conditions -precondition $precondition} if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} - ::nsf::method [::nsf::current object] $name $arguments $body {*}$conditions + array set "" [::nx::Object resolve_method_path -create -verbose [::nsf::current object] $name] + set r [::nsf::method $(object) $(methodName) $arguments $body {*}$conditions] + if {[info exists returns]} {nsf::methodproperty $(object) $r returns $returns} + return $r } # @method ::nx::Object#method @@ -130,10 +184,9 @@ set conditions [list] if {[info exists precondition]} {lappend conditions -precondition $precondition} if {[info exists postcondition]} {lappend conditions -postcondition $postcondition} - set r [::nsf::method [::nsf::current object] -per-object $name $arguments $body {*}$conditions] - if {[info exists returns]} { - ::nsf::methodproperty [::nsf::current object] $r returns $returns - } + array set "" [::nx::Object resolve_method_path -create -per-object -verbose [::nsf::current object] $name] + set r [::nsf::method $(object) -per-object $(methodName) $arguments $body {*}$conditions] + if {[info exists returns]} {nsf::methodproperty $(object) $r returns $returns} return $r } Index: tests/method-modifiers.tcl =================================================================== diff -u -r513f795175db0329e73b1c7d14fb73255d62235a -r797decf0bf5d838727a50e35df060f6dfd55e65d --- tests/method-modifiers.tcl (.../method-modifiers.tcl) (revision 513f795175db0329e73b1c7d14fb73255d62235a) +++ tests/method-modifiers.tcl (.../method-modifiers.tcl) (revision 797decf0bf5d838727a50e35df060f6dfd55e65d) @@ -276,4 +276,34 @@ ? {o b} b1 ? {o c} c1 ? {o d} "::o: unable to dispatch method 'd'" -} \ No newline at end of file +} + +Test case subcmd { + + Class create Foo { + + :method "Info filter guard" {filter} {return [current object]-[current method]} + :method "Info filter methods" {-guards pattern:optional} {return [current object]-[current method]} + :method "Info args" {} {return [current object]-[current method]} + :method "Info foo" {} {return [current object]-[current method]} + + :object method "INFO filter guard" {a b} {return [current object]-[current method]} + :object method "INFO filter methods" {-guards pattern:optional} {return [current object]-[current method]} + } + + ? {Foo INFO filter guard 1 2} ::Foo-guard + ? {Foo INFO filter methods a*} ::Foo-methods + + Foo create f1 { + :method "list length" {} {return [current object]-[current method]} + :method "list reverse" {} {return [current object]-[current method]} + } + + ? {f1 Info filter guard x} "::f1-guard" + ? {f1 Info filter methods} "::f1-methods" + ? {f1 Info args} "::f1-args" + ? {f1 Info foo} "::f1-foo" + + ? {f1 list length} "::f1-length" + ? {f1 list reverse} "::f1-reverse" +}