Index: generic/gentclAPI.decls =================================================================== diff -u -r25416326167316f41d0a90ffa53bac3e1104128f -re767edf5c498094f6e00150541bfb7beab52b619 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 25416326167316f41d0a90ffa53bac3e1104128f) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision e767edf5c498094f6e00150541bfb7beab52b619) @@ -301,8 +301,7 @@ {-argName "object" -required 1 -type object} {-argName "-defined"} {-argName "-per-object"} - {-argName "-noprocs"} - {-argName "-nocmds"} + {-argName "-methodtype" -nrargs 1 -type "all|scripted|compiled|alias|forwarder|object|setter"} {-argName "-nomixins"} {-argName "-incontext"} {-argName "pattern"} Index: generic/gentclAPI.tcl =================================================================== diff -u -rf316e4ef5e27eedc5ed7cb1a4d90ff0d86b53ca8 -re767edf5c498094f6e00150541bfb7beab52b619 --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision f316e4ef5e27eedc5ed7cb1a4d90ff0d86b53ca8) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision e767edf5c498094f6e00150541bfb7beab52b619) @@ -11,8 +11,7 @@ set ::objCmdProc "(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv \[\]);" proc convertername {type argname} { - #return [string totitle [string map [list | _] $type]] - return [string totitle $argname] + return [string totitle [string trimleft $argname -]] } proc createconverter {type argname} { @@ -22,8 +21,8 @@ } set domain [split $type |] set opts "static CONST char *opts\[\] = {\"[join $domain {", "}]\", NULL};" - set enums [list ${argname}NULL] - foreach d $domain {lappend enums $argname[string totitle [string map [list - _] $d]]Idx} + set enums [list ${name}NULL] + foreach d $domain {lappend enums $name[string totitle [string map [list - _] $d]]Idx} subst { static int convertTo${name}(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; @@ -32,7 +31,7 @@ *clientData = (ClientData) index + 1; return result; } -enum ${argname}Idx {[join $enums {, }]}; +enum ${name}Idx {[join $enums {, }]}; } } @@ -44,6 +43,7 @@ "" {set type NULL} default {set type $(-type)} } + set argName $(-argName) switch -glob $type { "NULL" {set converter String} "boolean" {set converter Boolean} @@ -60,7 +60,7 @@ set (-argName) $type } } - lappend l "{\"$(-argName)\", $(-required), $(-nrargs), convertTo$converter}" + lappend l "{\"$argName\", $(-required), $(-nrargs), convertTo$converter}" } join $l ",\n " } @@ -104,11 +104,12 @@ set calledArg $varName set type "int " if {$(-nrargs) == 1} { - switch $(-type) { + switch -glob $(-type) { "" {set type "char *"} "class" {set type "XOTclClass *"} "object" {set type "XOTclObject *"} "tclobj" {set type "Tcl_Obj *"} + "*|*" {set type "int "} default {error "type '$(-type)' not allowed for parameter"} } } Index: generic/tclAPI.h =================================================================== diff -u -r25416326167316f41d0a90ffa53bac3e1104128f -re767edf5c498094f6e00150541bfb7beab52b619 --- generic/tclAPI.h (.../tclAPI.h) (revision 25416326167316f41d0a90ffa53bac3e1104128f) +++ generic/tclAPI.h (.../tclAPI.h) (revision e767edf5c498094f6e00150541bfb7beab52b619) @@ -1,12 +1,21 @@ +static int convertToMethodtype(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { + int index, result; + static CONST char *opts[] = {"all", "scripted", "compiled", "alias", "forwarder", "object", "setter", NULL}; + result = Tcl_GetIndexFromObj(interp, objPtr, opts, "-methodtype", 0, &index); + *clientData = (ClientData) index + 1; + return result; +} +enum MethodtypeIdx {MethodtypeNULL, MethodtypeAllIdx, MethodtypeScriptedIdx, MethodtypeCompiledIdx, MethodtypeAliasIdx, MethodtypeForwarderIdx, MethodtypeObjectIdx, MethodtypeSetterIdx}; + static int convertToConfigureoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; static CONST char *opts[] = {"filter", "softrecreate", "cacheinterface", NULL}; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "configureoption", 0, &index); *clientData = (ClientData) index + 1; return result; } -enum configureoptionIdx {configureoptionNULL, configureoptionFilterIdx, configureoptionSoftrecreateIdx, configureoptionCacheinterfaceIdx}; +enum ConfigureoptionIdx {ConfigureoptionNULL, ConfigureoptionFilterIdx, ConfigureoptionSoftrecreateIdx, ConfigureoptionCacheinterfaceIdx}; static int convertToSelfoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; @@ -15,7 +24,7 @@ *clientData = (ClientData) index + 1; return result; } -enum selfoptionIdx {selfoptionNULL, selfoptionProcIdx, selfoptionClassIdx, selfoptionActivelevelIdx, selfoptionArgsIdx, selfoptionActivemixinIdx, selfoptionCalledprocIdx, selfoptionCalledmethodIdx, selfoptionCalledclassIdx, selfoptionCallingprocIdx, selfoptionCallingclassIdx, selfoptionCallinglevelIdx, selfoptionCallingobjectIdx, selfoptionFilterregIdx, selfoptionIsnextcallIdx, selfoptionNextIdx}; +enum SelfoptionIdx {SelfoptionNULL, SelfoptionProcIdx, SelfoptionClassIdx, SelfoptionActivelevelIdx, SelfoptionArgsIdx, SelfoptionActivemixinIdx, SelfoptionCalledprocIdx, SelfoptionCalledmethodIdx, SelfoptionCalledclassIdx, SelfoptionCallingprocIdx, SelfoptionCallingclassIdx, SelfoptionCallinglevelIdx, SelfoptionCallingobjectIdx, SelfoptionFilterregIdx, SelfoptionIsnextcallIdx, SelfoptionNextIdx}; static int convertToObjectkind(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; @@ -24,7 +33,7 @@ *clientData = (ClientData) index + 1; return result; } -enum objectkindIdx {objectkindNULL, objectkindTypeIdx, objectkindObjectIdx, objectkindClassIdx, objectkindMetaclassIdx, objectkindMixinIdx}; +enum ObjectkindIdx {ObjectkindNULL, ObjectkindTypeIdx, ObjectkindObjectIdx, ObjectkindClassIdx, ObjectkindMetaclassIdx, ObjectkindMixinIdx}; static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; @@ -33,7 +42,7 @@ *clientData = (ClientData) index + 1; return result; } -enum methodpropertyIdx {methodpropertyNULL, methodpropertyProtectedIdx, methodpropertyStaticIdx, methodpropertySlotobjIdx}; +enum MethodpropertyIdx {MethodpropertyNULL, MethodpropertyProtectedIdx, MethodpropertyStaticIdx, MethodpropertySlotobjIdx}; static int convertToRelationtype(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int index, result; @@ -42,7 +51,7 @@ *clientData = (ClientData) index + 1; return result; } -enum relationtypeIdx {relationtypeNULL, relationtypeMixinIdx, relationtypeInstmixinIdx, relationtypeObject_mixinIdx, relationtypeClass_mixinIdx, relationtypeFilterIdx, relationtypeInstfilterIdx, relationtypeObject_filterIdx, relationtypeClass_filterIdx, relationtypeClassIdx, relationtypeSuperclassIdx, relationtypeRootclassIdx}; +enum RelationtypeIdx {RelationtypeNULL, RelationtypeMixinIdx, RelationtypeInstmixinIdx, RelationtypeObject_mixinIdx, RelationtypeClass_mixinIdx, RelationtypeFilterIdx, RelationtypeInstfilterIdx, RelationtypeObject_filterIdx, RelationtypeClass_filterIdx, RelationtypeClassIdx, RelationtypeSuperclassIdx, RelationtypeRootclassIdx}; typedef struct { @@ -210,7 +219,7 @@ static int XOTclObjInfoForwardMethod(Tcl_Interp *interp, XOTclObject *object, int withDefinition, char *pattern); static int XOTclObjInfoHasnamespaceMethod(Tcl_Interp *interp, XOTclObject *object); static int XOTclObjInfoInvarMethod(Tcl_Interp *interp, XOTclObject *object); -static int XOTclObjInfoMethodsMethod(Tcl_Interp *interp, XOTclObject *object, int withDefined, int withPer_object, int withNoprocs, int withNocmds, int withNomixins, int withIncontext, char *pattern); +static int XOTclObjInfoMethodsMethod(Tcl_Interp *interp, XOTclObject *object, int withDefined, int withPer_object, int withMethodtype, int withNomixins, int withIncontext, char *pattern); static int XOTclObjInfoMixinMethod(Tcl_Interp *interp, XOTclObject *object, int withGuards, int withOrder, char *patternString, XOTclObject *patternObj); static int XOTclObjInfoMixinguardMethod(Tcl_Interp *interp, XOTclObject *object, char *mixin); static int XOTclObjInfoParametercmdMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern); @@ -1304,14 +1313,13 @@ XOTclObject *object = (XOTclObject *)pc.clientData[0]; int withDefined = (int )pc.clientData[1]; int withPer_object = (int )pc.clientData[2]; - int withNoprocs = (int )pc.clientData[3]; - int withNocmds = (int )pc.clientData[4]; - int withNomixins = (int )pc.clientData[5]; - int withIncontext = (int )pc.clientData[6]; - char *pattern = (char *)pc.clientData[7]; + int withMethodtype = (int )pc.clientData[3]; + int withNomixins = (int )pc.clientData[4]; + int withIncontext = (int )pc.clientData[5]; + char *pattern = (char *)pc.clientData[6]; parseContextRelease(&pc); - return XOTclObjInfoMethodsMethod(interp, object, withDefined, withPer_object, withNoprocs, withNocmds, withNomixins, withIncontext, pattern); + return XOTclObjInfoMethodsMethod(interp, object, withDefined, withPer_object, withMethodtype, withNomixins, withIncontext, pattern); } } @@ -2452,12 +2460,11 @@ {"::xotcl::cmd::ObjectInfo::invar", XOTclObjInfoInvarMethodStub, 1, { {"object", 1, 0, convertToObject}} }, -{"::xotcl::cmd::ObjectInfo::methods", XOTclObjInfoMethodsMethodStub, 8, { +{"::xotcl::cmd::ObjectInfo::methods", XOTclObjInfoMethodsMethodStub, 7, { {"object", 1, 0, convertToObject}, {"-defined", 0, 0, convertToString}, {"-per-object", 0, 0, convertToString}, - {"-noprocs", 0, 0, convertToString}, - {"-nocmds", 0, 0, convertToString}, + {"-methodtype", 0, 1, convertToMethodtype}, {"-nomixins", 0, 0, convertToString}, {"-incontext", 0, 0, convertToString}, {"pattern", 0, 0, convertToString}} @@ -2601,7 +2608,7 @@ {"cmdName", 1, 0, convertToTclobj}} }, {"::xotcl::configure", XOTclConfigureCmdStub, 2, { - {"filter|softrecreate|cacheinterface", 1, 0, convertToConfigureoption}, + {"configureoption", 1, 0, convertToConfigureoption}, {"value", 0, 0, convertToTclobj}} }, {"::xotcl::createobjectsystem", XOTclCreateObjectSystemCmdStub, 2, { @@ -2625,7 +2632,7 @@ } }, {"::xotcl::self", XOTclGetSelfObjCmdStub, 1, { - {"proc|class|activelevel|args|activemixin|calledproc|calledmethod|calledclass|callingproc|callingclass|callinglevel|callingobject|filterreg|isnextcall|next", 0, 0, convertToSelfoption}} + {"selfoption", 0, 0, convertToSelfoption}} }, {"::xotcl::instvar", XOTclInstvarCmdStub, 2, { {"-object", 0, 1, convertToObject}, @@ -2637,14 +2644,14 @@ }, {"::xotcl::is", XOTclIsCmdStub, 3, { {"object", 1, 0, convertToTclobj}, - {"type|object|class|metaclass|mixin", 0, 0, convertToObjectkind}, + {"objectkind", 0, 0, convertToObjectkind}, {"value", 0, 0, convertToTclobj}} }, {"::xotcl::methodproperty", XOTclMethodPropertyCmdStub, 5, { {"object", 1, 0, convertToObject}, {"methodName", 1, 0, convertToString}, {"-per-object", 0, 0, convertToString}, - {"protected|static|slotobj", 1, 0, convertToMethodproperty}, + {"methodproperty", 1, 0, convertToMethodproperty}, {"value", 0, 0, convertToTclobj}} }, {"::xotcl::my", XOTclMyCmdStub, 3, { @@ -2665,7 +2672,7 @@ }, {"::xotcl::relation", XOTclRelationCmdStub, 3, { {"object", 1, 0, convertToObject}, - {"mixin|instmixin|object-mixin|class-mixin|filter|instfilter|object-filter|class-filter|class|superclass|rootclass", 1, 0, convertToRelationtype}, + {"relationtype", 1, 0, convertToRelationtype}, {"value", 0, 0, convertToTclobj}} }, {"::xotcl::setinstvar", XOTclSetInstvarCmdStub, 3, { Index: generic/xotcl.c =================================================================== diff -u -r25416326167316f41d0a90ffa53bac3e1104128f -re767edf5c498094f6e00150541bfb7beab52b619 --- generic/xotcl.c (.../xotcl.c) (revision 25416326167316f41d0a90ffa53bac3e1104128f) +++ generic/xotcl.c (.../xotcl.c) (revision e767edf5c498094f6e00150541bfb7beab52b619) @@ -9344,33 +9344,76 @@ } #endif +static Tcl_Command +GetOriginalCommand(Tcl_Command cmd) /* The imported command for which the original + * command should be returned. */ +{ + Tcl_Command importedCmd; + + while (1) { + /* dereference the namespace import reference chain */ + if ((importedCmd = TclGetOriginalCommand(cmd))) { + cmd = importedCmd; + } + /* dereference the XOtcl alias chain */ + if (Tcl_Command_deleteProc(cmd) == aliasCmdDeleteProc) { + AliasCmdClientData *tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd); + cmd = tcd->aliasedCmd; + continue; + } + break; + } + return cmd; +} + + static int -ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern, - int noProcs, int noCmds, Tcl_HashTable *dups, int onlyForwarder, int onlySetter) { +ListMethodKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern, int methodType, + Tcl_HashTable *dups, int onlyForwarder, int onlySetter) { Tcl_HashSearch hSrch; Tcl_HashEntry *hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0; for (; hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { char *key = Tcl_GetHashKey(table, hPtr); Tcl_Command importedCmd, cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - Tcl_ObjCmdProc *proc; + Tcl_ObjCmdProc *proc, *resolvedProc; - if ((importedCmd = TclGetOriginalCommand(cmd))) { - cmd = importedCmd; - } proc = Tcl_Command_objProc(cmd); + importedCmd = GetOriginalCommand(cmd); + resolvedProc = Tcl_Command_objProc(importedCmd); +#if 0 if (proc == XOTclProcAliasMethod || proc == XOTclObjscopedMethod) { AliasCmdClientData *tcd = Tcl_Command_objClientData(cmd); /* TODO: resolve our chain */ assert(tcd); - proc = tcd->objProc; + resolvedProc = tcd->objProc; } +#endif if (pattern && !Tcl_StringMatch(key, pattern)) continue; + if (proc == XOTclProcAliasMethod) { + if ((methodType & XOTCL_METHODTYPE_ALIAS) == 0) continue; + } + /* the following cases are disjoint */ + if (CmdIsProc(importedCmd)) { + /*fprintf(stderr,"%s scripted %d\n",key, methodType & XOTCL_METHODTYPE_SCRIPTED);*/ + if ((methodType & XOTCL_METHODTYPE_SCRIPTED) == 0) continue; + } else if (resolvedProc == XOTclForwardMethod) { + if ((methodType & XOTCL_METHODTYPE_FORWARDER) == 0) continue; + } else if (resolvedProc == XOTclSetterMethod) { + if ((methodType & XOTCL_METHODTYPE_SETTER) == 0) continue; + } else if (resolvedProc == XOTclObjDispatch) { + if ((methodType & XOTCL_METHODTYPE_OBJECT) == 0) continue; + } else if ((methodType & XOTCL_METHODTYPE_OTHER) == 0) { + /*fprintf(stderr,"OTHER %s not wanted %.4x\n",key, methodType);*/ + continue; + } + /* if (noCmds && proc != RUNTIME_STATE(interp)->objInterpProc) continue; if (noProcs && proc == RUNTIME_STATE(interp)->objInterpProc) continue; if (onlyForwarder && proc != XOTclForwardMethod) continue; if (onlySetter && proc != XOTclSetterMethod) continue; + */ /* XOTclObjscopedMethod ??? */ if (dups) { @@ -9481,35 +9524,35 @@ } result = TCL_OK; } else { - result = ListMethodKeys(interp, table, pattern, 1, 0, NULL, 1, 0); + result = ListMethodKeys(interp, table, pattern, XOTCL_METHODTYPE_FORWARDER, NULL, 1, 0); } return result; } static int ListMethods(Tcl_Interp *interp, XOTclObject *obj, char *pattern, - int withDefined, int withPer_object, - int noProcs, int noCmds, int noMixins, int inContext) { + int withDefined, int withPer_object, int methodType, + int noMixins, int inContext) { XOTclClasses *pl; Tcl_HashTable *cmdTable, dupsTable, *dups = &dupsTable; Tcl_InitHashTable(dups, TCL_STRING_KEYS); - /*fprintf(stderr, "listMethods %s %d %d %d %d\n", pattern, noProcs, noCmds, noMixins, inContext);*/ + /*fprintf(stderr, "listMethods %s %d %d\n", pattern, noMixins, inContext);*/ if (withDefined) { if (XOTclObjectIsClass(obj) && !withPer_object) { cmdTable = Tcl_Namespace_cmdTable(((XOTclClass *)obj)->nsPtr); } else { cmdTable = obj->nsPtr ? Tcl_Namespace_cmdTable(obj->nsPtr) : NULL; } - ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0, 0); + ListMethodKeys(interp, cmdTable, pattern, methodType, dups, 0, 0); Tcl_DeleteHashTable(dups); return TCL_OK; } if (obj->nsPtr) { cmdTable = Tcl_Namespace_cmdTable(obj->nsPtr); - ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0, 0); + ListMethodKeys(interp, cmdTable, pattern, methodType, dups, 0, 0); } if (!noMixins) { @@ -9528,7 +9571,7 @@ } if (mixin && guardOk == TCL_OK) { Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(mixin->nsPtr); - ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0, 0); + ListMethodKeys(interp, cmdTable, pattern, methodType, dups, 0, 0); } } } @@ -9537,7 +9580,7 @@ /* append per-class filters */ for (pl = ComputeOrder(obj->cl, obj->cl->order, Super); pl; pl = pl->nextPtr) { Tcl_HashTable *cmdTable = Tcl_Namespace_cmdTable(pl->cl->nsPtr); - ListMethodKeys(interp, cmdTable, pattern, noProcs, noCmds, dups, 0, 0); + ListMethodKeys(interp, cmdTable, pattern, methodType, dups, 0, 0); } Tcl_DeleteHashTable(dups); return TCL_OK; @@ -9653,28 +9696,6 @@ * End result setting commands ********************************/ -static Tcl_Command -GetOriginalCommand(Tcl_Command cmd) /* The imported command for which the original - * command should be returned. */ -{ - Tcl_Command importedCmd; - - while (1) { - /* dereference the namespace import reference chain */ - if ((importedCmd = TclGetOriginalCommand(cmd))) { - cmd = importedCmd; - } - /* dereference the XOtcl alias chain */ - if (Tcl_Command_deleteProc(cmd) == aliasCmdDeleteProc) { - AliasCmdClientData *tcd = (AliasCmdClientData *)Tcl_Command_objClientData(cmd); - cmd = tcd->aliasedCmd; - continue; - } - break; - } - return cmd; -} - /********************************* * Begin generated XOTcl commands *********************************/ @@ -9823,20 +9844,20 @@ } switch (configureoption) { - case configureoptionFilterIdx: + case ConfigureoptionFilterIdx: Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (RUNTIME_STATE(interp)->doFilters)); if (value) RUNTIME_STATE(interp)->doFilters = bool; break; - case configureoptionSoftrecreateIdx: + case ConfigureoptionSoftrecreateIdx: Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (RUNTIME_STATE(interp)->doSoftrecreate)); if (value) RUNTIME_STATE(interp)->doSoftrecreate = bool; break; - case configureoptionCacheinterfaceIdx: + case ConfigureoptionCacheinterfaceIdx: Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (RUNTIME_STATE(interp)->cacheInterface)); if (value) @@ -10095,31 +10116,31 @@ XOTclClass *cl; switch (objectkind) { - case objectkindTypeIdx: + case ObjectkindTypeIdx: if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " type "); success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) && (GetClassFromObj(interp, value, &cl, 0) == TCL_OK) && isSubType(obj->cl, cl); break; - case objectkindObjectIdx: + case ObjectkindObjectIdx: if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " object"); success = (GetObjectFromObj(interp, object, &obj) == TCL_OK); break; - case objectkindClassIdx: + case ObjectkindClassIdx: if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " class"); success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) && XOTclObjectIsClass(obj); break; - case objectkindMetaclassIdx: + case ObjectkindMetaclassIdx: if (value != NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " metaclass"); success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) && XOTclObjectIsClass(obj) && IsMetaClass(interp, (XOTclClass*)obj, 1); break; - case objectkindMixinIdx: + case ObjectkindMixinIdx: if (value == NULL) return XOTclObjErrArgCnt(interp, NULL, NULL, " mixin "); success = (GetObjectFromObj(interp, object, &obj) == TCL_OK) && (GetClassFromObj(interp, value, &cl, 0) == TCL_OK) @@ -10166,10 +10187,10 @@ (char *) NULL); } - if (methodproperty == methodpropertyProtectedIdx - || methodproperty == methodpropertyStaticIdx) { + if (methodproperty == MethodpropertyProtectedIdx + || methodproperty == MethodpropertyStaticIdx) { - int flag = methodproperty == methodpropertyProtectedIdx ? + int flag = methodproperty == MethodpropertyProtectedIdx ? XOTCL_CMD_PROTECTED_METHOD : XOTCL_CMD_STATIC_METHOD; @@ -10586,28 +10607,28 @@ int i; switch (relationtype) { - case relationtypeObject_mixinIdx: - case relationtypeMixinIdx: - case relationtypeObject_filterIdx: - case relationtypeFilterIdx: + case RelationtypeObject_mixinIdx: + case RelationtypeMixinIdx: + case RelationtypeObject_filterIdx: + case RelationtypeFilterIdx: if (value == NULL) { objopt = object->opt; switch (relationtype) { - case relationtypeObject_mixinIdx: - case relationtypeMixinIdx: return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1, NULL) : TCL_OK; - case relationtypeObject_filterIdx: - case relationtypeFilterIdx: return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; + case RelationtypeObject_mixinIdx: + case RelationtypeMixinIdx: return objopt ? MixinInfo(interp, objopt->mixins, NULL, 1, NULL) : TCL_OK; + case RelationtypeObject_filterIdx: + case RelationtypeFilterIdx: return objopt ? FilterInfo(interp, objopt->filters, NULL, 1, 0) : TCL_OK; } } if (Tcl_ListObjGetElements(interp, value, &oc, &ov) != TCL_OK) return TCL_ERROR; objopt = XOTclRequireObjectOpt(object); break; - case relationtypeClass_mixinIdx: - case relationtypeInstmixinIdx: - case relationtypeClass_filterIdx: - case relationtypeInstfilterIdx: + case RelationtypeClass_mixinIdx: + case RelationtypeInstmixinIdx: + case RelationtypeClass_filterIdx: + case RelationtypeInstfilterIdx: if (XOTclObjectIsClass(object)) { cl = (XOTclClass *)object; } else { @@ -10617,10 +10638,10 @@ if (value == NULL) { clopt = cl->opt; switch (relationtype) { - case relationtypeClass_mixinIdx: - case relationtypeInstmixinIdx: return clopt ? MixinInfo(interp, clopt->instmixins, NULL, 1, NULL) : TCL_OK; - case relationtypeClass_filterIdx: - case relationtypeInstfilterIdx: return objopt ? FilterInfo(interp, clopt->instfilters, NULL, 1, 0) : TCL_OK; + case RelationtypeClass_mixinIdx: + case RelationtypeInstmixinIdx: return clopt ? MixinInfo(interp, clopt->instmixins, NULL, 1, NULL) : TCL_OK; + case RelationtypeClass_filterIdx: + case RelationtypeInstfilterIdx: return objopt ? FilterInfo(interp, clopt->instfilters, NULL, 1, 0) : TCL_OK; } } @@ -10629,7 +10650,7 @@ clopt = XOTclRequireClassOpt(cl); break; - case relationtypeSuperclassIdx: + case RelationtypeSuperclassIdx: if (!XOTclObjectIsClass(object)) return XOTclObjErrType(interp, object->cmdName, "Class"); cl = (XOTclClass *)object; @@ -10640,7 +10661,7 @@ return TCL_ERROR; return SuperclassAdd(interp, cl, oc, ov, value, cl->object.cl); - case relationtypeClassIdx: + case RelationtypeClassIdx: if (value == NULL) { Tcl_SetObjResult(interp, object->cl->object.cmdName); return TCL_OK; @@ -10649,7 +10670,7 @@ if (!cl) return XOTclErrBadVal(interp, "class", "a class", objectName(object)); return changeClass(interp, object, cl); - case relationtypeRootclassIdx: + case RelationtypeRootclassIdx: { XOTclClass *metaClass; @@ -10677,8 +10698,8 @@ } switch (relationtype) { - case relationtypeObject_mixinIdx: - case relationtypeMixinIdx: + case RelationtypeObject_mixinIdx: + case RelationtypeMixinIdx: if (objopt->mixins) { XOTclCmdList *cmdlist, *del; for (cmdlist = objopt->mixins; cmdlist; cmdlist = cmdlist->nextPtr) { @@ -10728,8 +10749,8 @@ FilterComputeDefined(interp, object); break; - case relationtypeObject_filterIdx: - case relationtypeFilterIdx: + case RelationtypeObject_filterIdx: + case RelationtypeFilterIdx: if (objopt->filters) CmdListRemoveList(&objopt->filters, GuardDel); @@ -10741,8 +10762,8 @@ /*FilterComputeDefined(interp, obj);*/ break; - case relationtypeClass_mixinIdx: - case relationtypeInstmixinIdx: + case RelationtypeClass_mixinIdx: + case RelationtypeInstmixinIdx: if (clopt->instmixins) { RemoveFromClassMixinsOf(cl->object.id, clopt->instmixins); @@ -10775,8 +10796,8 @@ } break; - case relationtypeClass_filterIdx: - case relationtypeInstfilterIdx: + case RelationtypeClass_filterIdx: + case RelationtypeInstfilterIdx: if (clopt->instfilters) CmdListRemoveList(&clopt->instfilters, GuardDel); @@ -10790,6 +10811,7 @@ } return TCL_OK; } + static int XOTclGetSelfObjCmd(Tcl_Interp *interp, int selfoption) { XOTclObject *obj = GetSelfObj(interp); XOTclCallStackContent *csc; @@ -10806,12 +10828,12 @@ } } - if (!obj && selfoption != selfoptionCallinglevelIdx) { + if (!obj && selfoption != SelfoptionCallinglevelIdx) { return XOTclVarErrMsg(interp, "self: no current object", (char *) NULL); } switch (selfoption) { - case selfoptionProcIdx: { /* proc subcommand */ + case SelfoptionProcIdx: { /* proc subcommand */ csc = CallStackGetTopFrame(interp, NULL); if (csc) { CONST char *procName = Tcl_GetCommandName(interp, csc->cmdPtr); @@ -10822,18 +10844,18 @@ break; } - case selfoptionClassIdx: { /* class subcommand */ + case SelfoptionClassIdx: { /* class subcommand */ csc = CallStackGetTopFrame(interp, NULL); Tcl_SetObjResult(interp, csc->cl ? csc->cl->object.cmdName : XOTclGlobalObjects[XOTE_EMPTY]); break; } - case selfoptionActivelevelIdx: { + case SelfoptionActivelevelIdx: { Tcl_SetObjResult(interp, computeLevelObj(interp, ACTIVE_LEVEL)); break; } - case selfoptionArgsIdx: { + case SelfoptionArgsIdx: { int nobjc; Tcl_Obj **nobjv; Tcl_CallFrame *topFramePtr; @@ -10845,7 +10867,7 @@ break; } - case selfoptionActivemixinIdx: { + case SelfoptionActivemixinIdx: { XOTclObject *o = NULL; if (RUNTIME_STATE(interp)->cmdPtr) { o = XOTclGetObjectFromCmdPtr(RUNTIME_STATE(interp)->cmdPtr); @@ -10854,8 +10876,8 @@ break; } - case selfoptionCalledprocIdx: - case selfoptionCalledmethodIdx: { + case SelfoptionCalledprocIdx: + case SelfoptionCalledmethodIdx: { csc = CallStackFindActiveFilter(interp); if (csc) { Tcl_SetObjResult(interp, csc->filterStackEntry->calledProc); @@ -10866,36 +10888,36 @@ break; } - case selfoptionCalledclassIdx: + case SelfoptionCalledclassIdx: Tcl_SetResult(interp, className(FindCalledClass(interp, obj)), TCL_VOLATILE); break; - case selfoptionCallingprocIdx: + case SelfoptionCallingprocIdx: csc = XOTclCallStackFindLastInvocation(interp, 1, NULL); Tcl_SetResult(interp, csc ? (char *)Tcl_GetCommandName(interp, csc->cmdPtr) : "", TCL_VOLATILE); break; - case selfoptionCallingclassIdx: + case SelfoptionCallingclassIdx: csc = XOTclCallStackFindLastInvocation(interp, 1, NULL); Tcl_SetObjResult(interp, csc && csc->cl ? csc->cl->object.cmdName : XOTclGlobalObjects[XOTE_EMPTY]); break; - case selfoptionCallinglevelIdx: + case SelfoptionCallinglevelIdx: if (!obj) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetObjResult(interp, computeLevelObj(interp, CALLING_LEVEL)); } break; - case selfoptionCallingobjectIdx: + case SelfoptionCallingobjectIdx: csc = XOTclCallStackFindLastInvocation(interp, 1, NULL); Tcl_SetObjResult(interp, csc ? csc->self->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); break; - case selfoptionFilterregIdx: + case SelfoptionFilterregIdx: csc = CallStackFindActiveFilter(interp); if (csc) { Tcl_SetObjResult(interp, FilterFindReg(interp, obj, csc->cmdPtr)); @@ -10906,7 +10928,7 @@ } break; - case selfoptionIsnextcallIdx: { + case SelfoptionIsnextcallIdx: { Tcl_CallFrame *framePtr; csc = CallStackGetTopFrame(interp, &framePtr); #if defined(TCL85STACK) @@ -10922,7 +10944,7 @@ break; } - case selfoptionNextIdx: + case SelfoptionNextIdx: result = FindSelfNext(interp, obj); break; } @@ -12091,11 +12113,39 @@ } static int XOTclObjInfoMethodsMethod(Tcl_Interp *interp, XOTclObject *object, - int withDefined, int withPer_object, - int withNoprocs, int withNocmds, int withNomixins, - int withIncontext, char *pattern) { + int withDefined, int withPer_object, + int withMethodtype, + int withNomixins, + int withIncontext, char *pattern) { + + int methodType; + + switch (withMethodtype) { + case MethodtypeNULL: /* default */ + case MethodtypeAllIdx: + methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_CMD; + break; + case MethodtypeScriptedIdx: + methodType = XOTCL_METHODTYPE_SCRIPTED|XOTCL_METHODTYPE_ALIAS; + break; + case MethodtypeCompiledIdx: + methodType = XOTCL_METHODTYPE_CMD; + break; + case MethodtypeForwarderIdx: + methodType = XOTCL_METHODTYPE_FORWARDER; + break; + case MethodtypeAliasIdx: + methodType = XOTCL_METHODTYPE_ALIAS; + break; + case MethodtypeSetterIdx: + methodType = XOTCL_METHODTYPE_SETTER; + break; + case MethodtypeObjectIdx: + methodType = XOTCL_METHODTYPE_OBJECT; + break; + } return ListMethods(interp, object, pattern, withDefined, withPer_object, - withNoprocs, withNocmds, withNomixins, withIncontext); + methodType, withNomixins, withIncontext); } static int XOTclObjInfoMixinMethod(Tcl_Interp *interp, XOTclObject *object, int withGuards, int withOrder, @@ -12121,7 +12171,7 @@ static int XOTclObjInfoParametercmdMethod(Tcl_Interp *interp, XOTclObject *object, char *pattern) { if (object->nsPtr) { - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(object->nsPtr), pattern, 1, 0, 0, 0, 1); + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(object->nsPtr), pattern, XOTCL_METHODTYPE_SETTER, 0, 0, 1); } return TCL_OK; } @@ -12351,7 +12401,7 @@ } static int XOTclClassInfoInstparametercmdMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern) { - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern, 1, 0, 0, 0, 1); + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern, XOTCL_METHODTYPE_SETTER, 0, 0, 1); } static int XOTclClassInfoInstparamsMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName, int withVarnames) { Index: generic/xotclInt.h =================================================================== diff -u -rafa1cb8064311ef406ae50c499c026c8576393f8 -re767edf5c498094f6e00150541bfb7beab52b619 --- generic/xotclInt.h (.../xotclInt.h) (revision afa1cb8064311ef406ae50c499c026c8576393f8) +++ generic/xotclInt.h (.../xotclInt.h) (revision e767edf5c498094f6e00150541bfb7beab52b619) @@ -425,6 +425,15 @@ #define XOTCL_ARG_NOARG 0x0010 #define XOTCL_ARG_RELATION 0x0100 +/* method types */ +#define XOTCL_METHODTYPE_ALIAS 0x0001 +#define XOTCL_METHODTYPE_SCRIPTED 0x0002 +#define XOTCL_METHODTYPE_SETTER 0x0004 +#define XOTCL_METHODTYPE_FORWARDER 0x0008 +#define XOTCL_METHODTYPE_OBJECT 0x0010 +#define XOTCL_METHODTYPE_OTHER 0x0100 +#define XOTCL_METHODTYPE_CMD XOTCL_METHODTYPE_ALIAS|XOTCL_METHODTYPE_SETTER|XOTCL_METHODTYPE_FORWARDER|XOTCL_METHODTYPE_OBJECT|XOTCL_METHODTYPE_OTHER + /* disallowed options */ #define XOTCL_ARG_METHOD_PARAMETER (XOTCL_ARG_RELATION) /* maybe add ARG_INITCMD */ #define XOTCL_ARG_OBJECT_PARAMETER 0 Index: library/serialize/Serializer.xotcl =================================================================== diff -u -r25416326167316f41d0a90ffa53bac3e1104128f -re767edf5c498094f6e00150541bfb7beab52b619 --- library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 25416326167316f41d0a90ffa53bac3e1104128f) +++ library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision e767edf5c498094f6e00150541bfb7beab52b619) @@ -204,14 +204,14 @@ #if {![$o istype ::xotcl::Slot]} {append cmd " -noinit"} append cmd " -noinit" append cmd " \\\n" - foreach i [$o info methods -defined -nocmd] { + foreach i [::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype scripted] { append cmd " " [my method-serialize $o $i ""] " \\\n" } - foreach i [$o info forward] { + foreach i [::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype forward] { set fwd [concat [list forward $i] [$o info forward -definition $i]] append cmd \t [my pcmd $fwd] " \\\n" } - foreach i [$o info parametercmd] { + foreach i [::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype setter] { append cmd \t [my pcmd [list parametercmd $i]] " \\\n" } set vset {} Index: tests/testx.xotcl =================================================================== diff -u -r217d826e64107056ae97176552cae3c776991b9e -re767edf5c498094f6e00150541bfb7beab52b619 --- tests/testx.xotcl (.../testx.xotcl) (revision 217d826e64107056ae97176552cae3c776991b9e) +++ tests/testx.xotcl (.../testx.xotcl) (revision e767edf5c498094f6e00150541bfb7beab52b619) @@ -3102,7 +3102,6 @@ ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init isclass ismetaclass ismixin isobject istype move myProc myProc2 objectparameter objproc proc self setFilter signature unknown" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" - ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init instproc isclass ismetaclass ismixin isobject istype move objectparameter parameter proc self setFilter signature unknown uses" "B info methods -nocmds" namespace eval a {