Index: ChangeLog =================================================================== diff -u -r43284158ea27b871565471d45e6e5f1a6a959989 -r5003fb8069bfd0d2de1482c68a7ab68782c4b328 --- ChangeLog (.../ChangeLog) (revision 43284158ea27b871565471d45e6e5f1a6a959989) +++ ChangeLog (.../ChangeLog) (revision 5003fb8069bfd0d2de1482c68a7ab68782c4b328) @@ -63,6 +63,9 @@ C c1 ;# c1 has no no default value for "a", before it had ====== +2009-06-28 + - objv-stubs for all 23 class info methods + 2009-06-27 - changed method name "instdestroy" into "dealloc" - replaced occurrences of "instdestroy" by "dealloc" in documentation Index: generic/gentclAPI.tcl =================================================================== diff -u -rce552d49dd2f135f21cefb4b88c9bf1357881c2e -r5003fb8069bfd0d2de1482c68a7ab68782c4b328 --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision ce552d49dd2f135f21cefb4b88c9bf1357881c2e) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 5003fb8069bfd0d2de1482c68a7ab68782c4b328) @@ -216,7 +216,64 @@ infoClassMethod instmixinof XOTclClassInfoInstmixinofMethod { {-argName "class" -required 1 -nrargs 0 -type class} {-argName "-closure"} - {-argName "pattern" -type objpattern}} + {-argName "pattern" -type objpattern} +} +infoClassMethod instnonposargs XOTclClassInfoInstnonposargsMethod { + {-argName "class" -required 1 -nrargs 0 -type class} + {-argName "methodName" -required 1} +} +infoClassMethod instparametercmd XOTclClassInfoInstparametercmdMethod { + {-argName "class" -required 1 -nrargs 0 -type class} + {-argName "pattern"} +} + +infoClassMethod instpost XOTclClassInfoInstpostMethod { + {-argName "class" -required 1 -nrargs 0 -type class} + {-argName "methodName" -required 1} +} + +infoClassMethod instpre XOTclClassInfoInstpreMethod { + {-argName "class" -required 1 -nrargs 0 -type class} + {-argName "methodName" -required 1} +} + +infoClassMethod instprocs XOTclClassInfoInstprocsMethod { + {-argName "class" -required 1 -nrargs 0 -type class} + {-argName "pattern"} +} + +infoClassMethod mixinof XOTclClassInfoMixinofMethod { + {-argName "class" -required 1 -nrargs 0 -type class} + {-argName "-closure"} + {-argName "pattern" -type objpattern} +} + +infoClassMethod parameter XOTclClassInfoParameterMethod { + {-argName "class" -required 1 -nrargs 0 -type class} +} + +infoClassMethod slots XOTclClassInfoSlotsMethod { + {-argName "class" -required 1 -nrargs 0 -type class} +} + +infoClassMethod subclass XOTclClassInfoSubclassMethod { + {-argName "class" -required 1 -nrargs 0 -type class} + {-argName "-closure"} + {-argName "pattern" -type objpattern} +} + +infoClassMethod superclass XOTclClassInfoSuperclassMethod { + {-argName "class" -required 1 -nrargs 0 -type class} + {-argName "-closure"} + {-argName "pattern"} +} + + + + + + + genifds \ No newline at end of file Index: generic/tclAPI.h =================================================================== diff -u -rce552d49dd2f135f21cefb4b88c9bf1357881c2e -r5003fb8069bfd0d2de1482c68a7ab68782c4b328 --- generic/tclAPI.h (.../tclAPI.h) (revision ce552d49dd2f135f21cefb4b88c9bf1357881c2e) +++ generic/tclAPI.h (.../tclAPI.h) (revision 5003fb8069bfd0d2de1482c68a7ab68782c4b328) @@ -23,6 +23,16 @@ static int XOTclClassInfoInstmixinMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstmixinguardMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoInstmixinofMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoInstnonposargsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoInstparametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoInstpostMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoInstpreMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoInstprocsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoMixinofMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoParameterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoSlotsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoSubclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclClassInfoSuperclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclClassInfoHeritageMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern); static int XOTclClassInfoInstancesMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, char *patternString, XOTclObject *patternObj); @@ -37,6 +47,16 @@ static int XOTclClassInfoInstmixinMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, int withGuards, char *patternString, XOTclObject *patternObj); static int XOTclClassInfoInstmixinguardMethod(Tcl_Interp *interp, XOTclClass * class, char * mixin); static int XOTclClassInfoInstmixinofMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, char *patternString, XOTclObject *patternObj); +static int XOTclClassInfoInstnonposargsMethod(Tcl_Interp *interp, XOTclClass * class, char * methodName); +static int XOTclClassInfoInstparametercmdMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern); +static int XOTclClassInfoInstpostMethod(Tcl_Interp *interp, XOTclClass * class, char * methodName); +static int XOTclClassInfoInstpreMethod(Tcl_Interp *interp, XOTclClass * class, char * methodName); +static int XOTclClassInfoInstprocsMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern); +static int XOTclClassInfoMixinofMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, char *patternString, XOTclObject *patternObj); +static int XOTclClassInfoParameterMethod(Tcl_Interp *interp, XOTclClass * class); +static int XOTclClassInfoSlotsMethod(Tcl_Interp *interp, XOTclClass * class); +static int XOTclClassInfoSubclassMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, char *patternString, XOTclObject *patternObj); +static int XOTclClassInfoSuperclassMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, char * pattern); enum { XOTclClassInfoHeritageMethodIdx, @@ -51,7 +71,17 @@ XOTclClassInfoInstinvarMethodIdx, XOTclClassInfoInstmixinMethodIdx, XOTclClassInfoInstmixinguardMethodIdx, - XOTclClassInfoInstmixinofMethodIdx + XOTclClassInfoInstmixinofMethodIdx, + XOTclClassInfoInstnonposargsMethodIdx, + XOTclClassInfoInstparametercmdMethodIdx, + XOTclClassInfoInstpostMethodIdx, + XOTclClassInfoInstpreMethodIdx, + XOTclClassInfoInstprocsMethodIdx, + XOTclClassInfoMixinofMethodIdx, + XOTclClassInfoParameterMethodIdx, + XOTclClassInfoSlotsMethodIdx, + XOTclClassInfoSubclassMethodIdx, + XOTclClassInfoSuperclassMethodIdx } XOTclMethods; @@ -262,6 +292,159 @@ } } +static int +XOTclClassInfoInstnonposargsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstnonposargsMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + char * methodName = (char *)pc.clientData[1]; + + return XOTclClassInfoInstnonposargsMethod(interp, class, methodName); + + } +} + +static int +XOTclClassInfoInstparametercmdMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstparametercmdMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + char * pattern = (char *)pc.clientData[1]; + + return XOTclClassInfoInstparametercmdMethod(interp, class, pattern); + + } +} + +static int +XOTclClassInfoInstpostMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstpostMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + char * methodName = (char *)pc.clientData[1]; + + return XOTclClassInfoInstpostMethod(interp, class, methodName); + + } +} + +static int +XOTclClassInfoInstpreMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstpreMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + char * methodName = (char *)pc.clientData[1]; + + return XOTclClassInfoInstpreMethod(interp, class, methodName); + + } +} + +static int +XOTclClassInfoInstprocsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstprocsMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + char * pattern = (char *)pc.clientData[1]; + + return XOTclClassInfoInstprocsMethod(interp, class, pattern); + + } +} + +static int +XOTclClassInfoMixinofMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoMixinofMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + int withClosure = (int)pc.clientData[1]; + char *patternString = NULL; + XOTclObject *patternObj = NULL; + Tcl_Obj * pattern = (Tcl_Obj *)pc.clientData[2]; + + if (getMatchObject3(interp, pattern, &pc, &patternObj, &patternString) == -1) { + return TCL_OK; + } + + return XOTclClassInfoMixinofMethod(interp, class, withClosure, patternString, patternObj); + + } +} + +static int +XOTclClassInfoParameterMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoParameterMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + + return XOTclClassInfoParameterMethod(interp, class); + + } +} + +static int +XOTclClassInfoSlotsMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoSlotsMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + + return XOTclClassInfoSlotsMethod(interp, class); + + } +} + +static int +XOTclClassInfoSubclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoSubclassMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + int withClosure = (int)pc.clientData[1]; + char *patternString = NULL; + XOTclObject *patternObj = NULL; + Tcl_Obj * pattern = (Tcl_Obj *)pc.clientData[2]; + + if (getMatchObject3(interp, pattern, &pc, &patternObj, &patternString) == -1) { + return TCL_OK; + } + + return XOTclClassInfoSubclassMethod(interp, class, withClosure, patternString, patternObj); + + } +} + +static int +XOTclClassInfoSuperclassMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + if (parse2(clientData, interp, objc, objv, XOTclClassInfoSuperclassMethodIdx, &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclClass * class = (XOTclClass *)pc.clientData[0]; + int withClosure = (int)pc.clientData[1]; + char * pattern = (char *)pc.clientData[2]; + + return XOTclClassInfoSuperclassMethod(interp, class, withClosure, pattern); + + } +} + static methodDefinition2 methodDefinitons[] = { {"instances", XOTclClassInfoHeritageMethodStub, { {"class", 1, 0, "class"}, @@ -321,6 +504,47 @@ {"class", 1, 0, "class"}, {"-closure", 0, 0, NULL}, {"pattern", 0, 0, "objpattern"}} +}, +{"instnonposargs", XOTclClassInfoInstnonposargsMethodStub, { + {"class", 1, 0, "class"}, + {"methodName", 1, 0, NULL}} +}, +{"instparametercmd", XOTclClassInfoInstparametercmdMethodStub, { + {"class", 1, 0, "class"}, + {"pattern", 0, 0, NULL}} +}, +{"instpost", XOTclClassInfoInstpostMethodStub, { + {"class", 1, 0, "class"}, + {"methodName", 1, 0, NULL}} +}, +{"instpre", XOTclClassInfoInstpreMethodStub, { + {"class", 1, 0, "class"}, + {"methodName", 1, 0, NULL}} +}, +{"instprocs", XOTclClassInfoInstprocsMethodStub, { + {"class", 1, 0, "class"}, + {"pattern", 0, 0, NULL}} +}, +{"mixinof", XOTclClassInfoMixinofMethodStub, { + {"class", 1, 0, "class"}, + {"-closure", 0, 0, NULL}, + {"pattern", 0, 0, "objpattern"}} +}, +{"parameter", XOTclClassInfoParameterMethodStub, { + {"class", 1, 0, "class"}} +}, +{"slots", XOTclClassInfoSlotsMethodStub, { + {"class", 1, 0, "class"}} +}, +{"subclass", XOTclClassInfoSubclassMethodStub, { + {"class", 1, 0, "class"}, + {"-closure", 0, 0, NULL}, + {"pattern", 0, 0, "objpattern"}} +}, +{"superclass", XOTclClassInfoSuperclassMethodStub, { + {"class", 1, 0, "class"}, + {"-closure", 0, 0, NULL}, + {"pattern", 0, 0, NULL}} } }; Index: generic/xotcl.c =================================================================== diff -u -rce552d49dd2f135f21cefb4b88c9bf1357881c2e -r5003fb8069bfd0d2de1482c68a7ab68782c4b328 --- generic/xotcl.c (.../xotcl.c) (revision ce552d49dd2f135f21cefb4b88c9bf1357881c2e) +++ generic/xotcl.c (.../xotcl.c) (revision 5003fb8069bfd0d2de1482c68a7ab68782c4b328) @@ -3426,49 +3426,7 @@ return rc; } -/* - * get all instances of a class recursively into an initialized - * String key hashtable - */ -static int -XOTclClassInfoInstancesMethod1(Tcl_Interp *interp, XOTclClass *startCl, - int withClosure, char *pattern, XOTclObject *matchObject) { - Tcl_HashTable *table = &startCl->instances; - XOTclClasses *sc; - Tcl_HashSearch search; - Tcl_HashEntry *hPtr; - int rc = 0; - /*fprintf(stderr,"XOTclClassInfoInstancesMethod: clo %d pattern %s match %p\n", - withClosure, pattern, matchObject); */ - - for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { - XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); - /*fprintf(stderr, "match '%s' %p %p '%s'\n", - matchObject ? objectName(matchObject) : "NULL" ,matchObject, inst, objectName(inst));*/ - if (matchObject && inst == matchObject) { - Tcl_SetObjResult(interp, matchObject->cmdName); - return 1; - } - AppendMatchingElement(interp, inst->cmdName, pattern); - } - if (withClosure) { - for (sc = startCl->sub; sc; sc = sc->nextPtr) { - rc = XOTclClassInfoInstancesMethod1(interp, sc->cl, withClosure, pattern, matchObject); - if (rc) break; - } - } - return rc; -} - -static int -XOTclClassInfoInstancesMethod(Tcl_Interp *interp, XOTclClass *startCl, - int withClosure, char *pattern, XOTclObject *matchObject) { - XOTclClassInfoInstancesMethod1(interp, startCl, withClosure, pattern, matchObject); - return TCL_OK; -} - /* * get all instances of a class recursively into an initialized * String key hashtable @@ -6637,17 +6595,9 @@ return TCL_OK; } -static int -XOTclClassInfoHeritageMethod(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { - XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); - Tcl_ResetResult(interp); - if (pl) pl=pl->nextPtr; - for (; pl; pl = pl->nextPtr) { - AppendMatchingElement(interp, pl->cl->object.cmdName, pattern); - } - return TCL_OK; -} + + static XOTclClasses * ComputePrecedenceList(Tcl_Interp *interp, XOTclObject *obj, char *pattern, int withMixins) { @@ -11902,45 +11852,6 @@ Tcl_DString ds; } parseContext; -static int -getMatchObject2(Tcl_Interp *interp, parseContext *pc) { - if (pc->pattern && noMetaChars(pc->pattern)) { - pc->matchObject = XOTclpGetObject(interp, pc->pattern); - if (pc->matchObject) { - pc->pattern = ObjStr((pc->matchObject)->cmdName); - return 1; - } else { - /* object does not exist */ - Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); - return -1; - } - } else { - pc->matchObject = NULL; - if (pc->pattern) { - /* - * we have a pattern and meta characters, we might have - * to prefix it to ovoid abvious errors: since all object - * names are prefixed with ::, we add this prefix automatically - * to the match pattern, if it does not exist - */ - if (*(pc->pattern) && *(pc->pattern) != ':' && *(pc->pattern+1) && *(pc->pattern+1) != ':') { - /*fprintf(stderr, "pattern is not prefixed '%s'\n",pc->pattern);*/ - Tcl_DStringAppend(&pc->ds, "::", -1); - Tcl_DStringAppend(&pc->ds, pc->pattern, -1); - pc->pattern = Tcl_DStringValue(&pc->ds); - /*fprintf(stderr, "prefixed pattern = '%s'\n",pc->pattern);*/ - } - } - } - return 0; -} - - - -#define parseClass 0x0000001 -#define parsePattern 0x0000002 -#define parseMatchObject 0x0000002 - typedef struct { char *name; int required; @@ -11951,75 +11862,7 @@ typedef argDefinition interfaceDefinition[10]; -interfaceDefinition d = { - {"class", 1,0, "class"}, - {"-closure"}, - {"pattern"} -}; - -typedef struct { - char *name; - interfaceDefinition d; -} entry; - -entry entries[] = { - { - "dummy", { - {"class", 1, 0, "class"}, - {"-closure"}, - {"pattern"} - } - }, - { - "dummy2", { - {"class", 1, 0, "class"}, - {"-closure"}, - {"pattern"} - } - }, -}; - static int -parse(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - CONST char *options[], int flags, parseContext *pc) { - - int modifiers = getModifiers(objc, 2, objv, options, &pc->set); - int args = objc-modifiers; - int maxArgs = flags & parsePattern ? args + 1 : args; - - pc->resultIsSet = 0; - if (flags & parseClass) { - if (GetXOTclClassFromObj(interp, objv[1], &pc->cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); - } - - if (args < 2 || args > maxArgs) { - Tcl_Obj *msg = Tcl_NewStringObj(flags & parseClass ? "" : "", -1); - int i; - for (i=0; options[i]; i++) { - Tcl_AppendToObj(msg, " ?", 2); - Tcl_AppendToObj(msg, options[i], -1); - Tcl_AppendToObj(msg, "?", 1); - } - if (flags & parsePattern) { - Tcl_AppendToObj(msg, " ?pattern?", -1); - } - return XOTclObjErrArgCntObj(interp, objv[0], NULL, msg); - } - - pc->pattern = (flags & parsePattern) && args>2? ObjStr(objv[objc-1]) : NULL; - /*fprintf(stderr, "flags %d args %d both %d\n",flags & parsePattern, args, - (flags & parsePattern) && args>2);*/ - if (flags & parseMatchObject) { - DSTRING_INIT(&pc->ds); - if (getMatchObject2(interp, pc) == -1) { - pc->resultIsSet = 1; - } - } - return TCL_OK; -} - -static int convertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, char *type, ClientData *clientData) { switch (*type) { case 'c': @@ -12237,6 +12080,65 @@ } #endif + +/*************************** + * Begin Class Info methods + ***************************/ + +static int +XOTclClassInfoHeritageMethod(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { + XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); + Tcl_ResetResult(interp); + if (pl) pl=pl->nextPtr; + for (; pl; pl = pl->nextPtr) { + AppendMatchingElement(interp, pl->cl->object.cmdName, pattern); + } + return TCL_OK; +} + +/* + * get all instances of a class recursively into an initialized + * String key hashtable + */ +static int +XOTclClassInfoInstancesMethod1(Tcl_Interp *interp, XOTclClass *startCl, + int withClosure, char *pattern, XOTclObject *matchObject) { + Tcl_HashTable *table = &startCl->instances; + XOTclClasses *sc; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + int rc = 0; + + /*fprintf(stderr,"XOTclClassInfoInstancesMethod: clo %d pattern %s match %p\n", + withClosure, pattern, matchObject); */ + + for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); + /*fprintf(stderr, "match '%s' %p %p '%s'\n", + matchObject ? objectName(matchObject) : "NULL" ,matchObject, inst, objectName(inst));*/ + if (matchObject && inst == matchObject) { + Tcl_SetObjResult(interp, matchObject->cmdName); + return 1; + } + AppendMatchingElement(interp, inst->cmdName, pattern); + } + if (withClosure) { + for (sc = startCl->sub; sc; sc = sc->nextPtr) { + rc = XOTclClassInfoInstancesMethod1(interp, sc->cl, withClosure, pattern, matchObject); + if (rc) break; + } + } + return rc; +} + +static int +XOTclClassInfoInstancesMethod(Tcl_Interp *interp, XOTclClass *startCl, + int withClosure, char *pattern, XOTclObject *matchObject) { + XOTclClassInfoInstancesMethod1(interp, startCl, withClosure, pattern, matchObject); + return TCL_OK; +} + static int XOTclClassInfoInstargsMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName) { Tcl_Namespace *nsp = class->nsPtr; @@ -12255,45 +12157,14 @@ return ListProcBody(interp, Tcl_Namespace_cmdTable(class->nsPtr), methodName); } -#if 0 -static int -XOTclClassInfoInstbodyMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstbodyMethodIdx, &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclClass *cl = (XOTclClass *)pc.clientData[0]; - char *methodName = (char *)pc.clientData[1]; - Tcl_Namespace *nsp = cl->nsPtr; - return ListProcBody(interp, Tcl_Namespace_cmdTable(nsp), methodName); - } -} -#endif - static int XOTclClassInfoInstcommandsMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern) { return ListKeys(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern); } -#if 0 -static int -XOTclClassInfoInstcommandsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstcommandsMethodIdx, &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclClass *cl = (XOTclClass *)pc.clientData[0]; - char *pattern = (char *)pc.clientData[1]; - Tcl_Namespace *nsp = cl->nsPtr; - return ListKeys(interp, Tcl_Namespace_cmdTable(nsp), pattern); - } -} -#endif - static int XOTclClassInfoInstdefaultMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName, char *arg, Tcl_Obj *var) { - Tcl_Namespace *nsp = class->nsPtr; if (class->nonposArgsTable) { @@ -12307,54 +12178,11 @@ TCL_OK; } -#if 0 -static int -XOTclClassInfoInstdefaultMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstdefaultMethodIdx, &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclClass *cl = (XOTclClass *)pc.clientData[0]; - char *methodName = (char *)pc.clientData[1]; - char *arg = (char *)pc.clientData[2]; - Tcl_Obj *varObj = (Tcl_Obj *)pc.objv[3]; - Tcl_Namespace *nsp = cl->nsPtr; - - if (cl->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, methodName); - if (nonposArgs && nonposArgs->ordinaryArgs) { - return ListDefaultFromOrdinaryArgs(interp, methodName, nonposArgs, arg, varObj); - } - } - return nsp ? - ListProcDefault(interp, Tcl_Namespace_cmdTable(nsp), methodName, arg, varObj) : - TCL_OK; - } -} -#endif - static int XOTclClassInfoInstfilterMethod(Tcl_Interp *interp, XOTclClass * class, int withGuards, char * pattern) { return class->opt ? FilterInfo(interp, class->opt->instfilters, pattern, withGuards, 0) : TCL_OK; } -#if 0 -static int -XOTclClassInfoInstfilterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - if (parse2(clientData, interp, objc, objv, XOTclClassInfoInstfilterMethodIdx, &pc) != TCL_OK) { - return TCL_ERROR; - } else { - XOTclClass *cl = (XOTclClass *)pc.clientData[0]; - int withGuards = (int) pc.clientData[1]; - char *pattern = (char *)pc.clientData[2]; - XOTclClassOpt *opt = cl->opt; - - return opt ? FilterInfo(interp, opt->instfilters, pattern, withGuards, 0) : TCL_OK; - } -} -#endif - static int XOTclClassInfoInstfilterguardMethod(Tcl_Interp *interp, XOTclClass * class, char * filter) { return class->opt ? GuardList(interp, class->opt->instfilters, filter) : TCL_OK; @@ -12401,42 +12229,6 @@ return TCL_OK; } -#if 0 -static int -XOTclClassInfoInstmixinMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - static CONST char *options[] = {"-closure", "-guards", NULL}; - int rc, withGuards, withClosure; - XOTclClassOpt *opt; - - if ((rc = parse(clientData, interp, objc, objv, options, - parseClass|parsePattern|parseMatchObject, &pc)) != TCL_OK || pc.resultIsSet) { - return rc; - } - withClosure = pc.set & 1 << 0; - withGuards = pc.set & 1 << 1; - opt = pc.cl->opt; - - /*fprintf(stderr, "XOTclClassInfoInstmixinMethod guard %d clo %d set %.4x pattern '%s'\n", - withGuards,withClosure,pc.set,pc.pattern);*/ - - if (withClosure) { - Tcl_HashTable objTable, *commandTable = &objTable; - MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); - Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); - rc = getAllClassMixins(interp, commandTable, pc.cl, withGuards, pc.pattern, pc.matchObject); - if (pc.matchObject && rc && !withGuards) { - Tcl_SetObjResult(interp, rc ? pc.matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); - } - MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); - } else { - rc = opt ? MixinInfo(interp, opt->instmixins, pc.pattern, withGuards, pc.matchObject) : TCL_OK; - } - DSTRING_FREE(&pc.ds); - return TCL_OK; -} -#endif - static int XOTclClassInfoInstmixinguardMethod(Tcl_Interp *interp, XOTclClass * class, char * mixin) { return class->opt ? GuardList(interp, class->opt->instmixins, mixin) : TCL_OK; @@ -12466,213 +12258,147 @@ return TCL_OK; } - - - -static int -XOTclClassInfoMixinofMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - static CONST char *options[] = {"-closure", NULL}; - int rc, withClosure; - - if ((rc = parse(clientData, interp, objc, objv, options, - parseClass|parsePattern|parseMatchObject, &pc)) != TCL_OK || pc.resultIsSet) { - return rc; - } - withClosure = pc.set & 1 << 0; - - if (pc.cl->opt && !withClosure) { - rc = AppendMatchingElementsFromCmdList(interp, pc.cl->opt->isObjectMixinOf, pc.pattern, pc.matchObject); - } else if (withClosure) { - Tcl_HashTable objTable, *commandTable = &objTable; - MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); - Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); - rc = getAllObjectMixinsOf(interp, commandTable, pc.cl, 0, 1, pc.pattern, pc.matchObject); - MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); - } - - if (pc.matchObject) { - Tcl_SetObjResult(interp, rc ? pc.matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); - } - - DSTRING_FREE(&pc.ds); - return TCL_OK; -} - - - -static int -XOTclClassInfoInstnonposargsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); - - if (cl->nonposArgsTable) { - XOTclNonposArgs *nonposArgs = NonposArgsGet(cl->nonposArgsTable, ObjStr(objv[2])); +static int +XOTclClassInfoInstnonposargsMethod(Tcl_Interp *interp, XOTclClass * class, char * methodName) { + if (class->nonposArgsTable) { + XOTclNonposArgs *nonposArgs = NonposArgsGet(class->nonposArgsTable, methodName); if (nonposArgs) { Tcl_SetObjResult(interp, NonposArgsFormat(interp, nonposArgs->nonposArgs)); } } return TCL_OK; } -static int -XOTclClassInfoInstprocsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if (parse(clientData, interp, objc, objv, NULL, parseClass|parsePattern, &pc) != TCL_OK) { - return TCL_ERROR; - } - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(pc.cl->nsPtr), - pc.pattern, /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0, 0 ); +static int +XOTclClassInfoInstparametercmdMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern) { + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(class->nsPtr), pattern, 1, 0, 0, 0, 1); } -static int -XOTclClassInfoInstparametercmdMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - - if ((parse(clientData, interp, objc, objv, NULL, parseClass|parsePattern, &pc)) != TCL_OK) { - return TCL_ERROR; +static int +XOTclClassInfoInstpostMethod(Tcl_Interp *interp, XOTclClass * class, char * methodName) { + if (class->opt) { + XOTclProcAssertion *procs = AssertionFindProcs(class->opt->assertions, methodName); + if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); } - return ListMethodKeys(interp, Tcl_Namespace_cmdTable(pc.cl->nsPtr), pc.pattern, 1, 0, 0, 0, 1); + return TCL_OK; } - -static int -XOTclClassInfoInstpreMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; - - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], objv[1], " "); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); - - opt = cl->opt; - if (opt) { - XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); +static int +XOTclClassInfoInstpreMethod(Tcl_Interp *interp, XOTclClass *class, char *methodName) { + if (class->opt) { + XOTclProcAssertion *procs = AssertionFindProcs(class->opt->assertions, methodName); if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->pre)); } return TCL_OK; } -static int -XOTclClassInfoInstpostMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclClass *cl; - XOTclClassOpt *opt; +static int +XOTclClassInfoInstprocsMethod(Tcl_Interp *interp, XOTclClass * class, char * pattern) { + return ListMethodKeys(interp, Tcl_Namespace_cmdTable(class->nsPtr), + pattern, /*noProcs*/ 0, /*noCmds*/ 1, NULL, 0, 0 ); +} - if (objc != 3) return XOTclObjErrArgCnt(interp, objv[0], NULL, " "); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); +static int +XOTclClassInfoMixinofMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, + char *patternString, XOTclObject *patternObj) { + XOTclClassOpt *opt = class->opt; + int rc; - opt = cl->opt; - if (opt) { - XOTclProcAssertion *procs = AssertionFindProcs(opt->assertions, ObjStr(objv[2])); - if (procs) Tcl_SetObjResult(interp, AssertionList(interp, procs->post)); + if (opt && !withClosure) { + rc = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, patternString, patternObj); + } else if (withClosure) { + Tcl_HashTable objTable, *commandTable = &objTable; + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + rc = getAllObjectMixinsOf(interp, commandTable, class, 0, 1, patternString, patternObj); + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); } + + if (patternObj) { + Tcl_SetObjResult(interp, rc ? patternObj->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + return TCL_OK; } -static int -XOTclClassInfoParameterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { +static int +XOTclClassInfoParameterMethod(Tcl_Interp *interp, XOTclClass * class) { Tcl_DString ds, *dsPtr = &ds; - XOTclClass *cl; - XOTclObject *o; + XOTclObject *obj; - if (objc != 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(cl), -1); + Tcl_DStringAppend(dsPtr, className(class), -1); Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (o) { + obj = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (obj) { Tcl_Obj *varNameObj = Tcl_NewStringObj("__parameter",-1); - Tcl_Obj *parameters = XOTcl_ObjGetVar2((XOTcl_Object*)o, + Tcl_Obj *parameters = XOTcl_ObjGetVar2((XOTcl_Object*)obj, interp, varNameObj, NULL, TCL_LEAVE_ERR_MSG); if (parameters) { Tcl_SetObjResult(interp, parameters); } DECR_REF_COUNT(varNameObj); - } + } DSTRING_FREE(dsPtr); return TCL_OK; } -static int -XOTclClassInfoSuperclassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - static CONST char *options[] = {"-closure", NULL}; - int rc, withClosure; +static int +XOTclClassInfoSlotsMethod(Tcl_Interp *interp, XOTclClass * class) { + Tcl_DString ds, *dsPtr = &ds; + XOTclObject *obj; + int rc; - if ((rc = parse(clientData, interp, objc, objv, options, - parseClass|parsePattern, &pc)) != TCL_OK || pc.resultIsSet) { - return rc; + DSTRING_INIT(dsPtr); + Tcl_DStringAppend(dsPtr, className(class), -1); + Tcl_DStringAppend(dsPtr, "::slot", 6); + obj = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); + if (obj) { + rc = ListChildren(interp, obj, NULL, 0); + } else { + rc = TCL_OK; } - withClosure = pc.set & 1 << 0; - return ListSuperclasses(interp, pc.cl, pc.pattern, withClosure); + DSTRING_FREE(dsPtr); + return rc; } - -static int -XOTclClassInfoSubclassMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - parseContext pc; - static CONST char *options[] = {"-closure", NULL}; - int rc, withClosure; - - if ((rc = parse(clientData, interp, objc, objv, options, - parseClass|parsePattern|parseMatchObject, &pc)) != TCL_OK || pc.resultIsSet) { - return rc; - } - withClosure = pc.set & 1 << 0; - +static int +XOTclClassInfoSubclassMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, + char *patternString, XOTclObject *patternObj) { + int rc; if (withClosure) { - XOTclClasses *saved = pc.cl->order, *subclasses; - pc.cl->order = NULL; - subclasses = ComputeOrder(pc.cl, pc.cl->order, Sub); - pc.cl->order = saved; + XOTclClasses *saved = class->order, *subclasses; + class->order = NULL; + subclasses = ComputeOrder(class, class->order, Sub); + class->order = saved; if (subclasses) subclasses=subclasses->nextPtr; - rc = AppendMatchingElementsFromClasses(interp, subclasses, pc.pattern, pc.matchObject); + rc = AppendMatchingElementsFromClasses(interp, subclasses, patternString, patternObj); XOTclClassListFree(subclasses); } else { - rc = AppendMatchingElementsFromClasses(interp, pc.cl->sub, pc.pattern, pc.matchObject); + rc = AppendMatchingElementsFromClasses(interp, class->sub, patternString, patternObj); } - if (pc.matchObject) { - Tcl_SetObjResult(interp, rc ? pc.matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + if (patternObj) { + Tcl_SetObjResult(interp, rc ? patternObj->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); } - DSTRING_FREE(&pc.ds); return TCL_OK; } -static int -XOTclClassInfoSlotsMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - Tcl_DString ds, *dsPtr = &ds; - XOTclClass *cl; - XOTclObject *o; - int rc; +static int +XOTclClassInfoSuperclassMethod(Tcl_Interp *interp, XOTclClass * class, int withClosure, char * pattern) { + return ListSuperclasses(interp, class, pattern, withClosure); +} - if (objc < 2) return XOTclObjErrArgCnt(interp, objv[0], NULL, ""); - if (GetXOTclClassFromObj(interp, objv[1], &cl, 0) != TCL_OK) - return XOTclObjErrType(interp, objv[1], "Class"); +/*************************** + * End Class Info methods + ***************************/ - DSTRING_INIT(dsPtr); - Tcl_DStringAppend(dsPtr, className(cl), -1); - Tcl_DStringAppend(dsPtr, "::slot", 6); - o = XOTclpGetObject(interp, Tcl_DStringValue(dsPtr)); - if (o) { - rc = ListChildren(interp, o, NULL, 0); - } else { - rc = TCL_OK; - } - DSTRING_FREE(dsPtr); - return rc; -} + + + static int XOTclCInstParameterCmdMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { @@ -14584,16 +14310,16 @@ {"instmixin", XOTclClassInfoInstmixinMethodStub}, {"instmixinguard", XOTclClassInfoInstmixinguardMethodStub}, {"instmixinof", XOTclClassInfoInstmixinofMethodStub}, - {"instprocs", XOTclClassInfoInstprocsMethod}, - {"instnonposargs", XOTclClassInfoInstnonposargsMethod}, - {"instparametercmd",XOTclClassInfoInstparametercmdMethod}, - {"instpre", XOTclClassInfoInstpreMethod}, - {"instpost", XOTclClassInfoInstpostMethod}, - {"mixinof", XOTclClassInfoMixinofMethod}, - {"parameter", XOTclClassInfoParameterMethod}, - {"subclass", XOTclClassInfoSubclassMethod}, - {"superclass", XOTclClassInfoSuperclassMethod}, - {"slots", XOTclClassInfoSlotsMethod} + {"instprocs", XOTclClassInfoInstprocsMethodStub}, + {"instnonposargs", XOTclClassInfoInstnonposargsMethodStub}, + {"instparametercmd",XOTclClassInfoInstparametercmdMethodStub}, + {"instpre", XOTclClassInfoInstpreMethodStub}, + {"instpost", XOTclClassInfoInstpostMethodStub}, + {"mixinof", XOTclClassInfoMixinofMethodStub}, + {"parameter", XOTclClassInfoParameterMethodStub}, + {"subclass", XOTclClassInfoSubclassMethodStub}, + {"superclass", XOTclClassInfoSuperclassMethodStub}, + {"slots", XOTclClassInfoSlotsMethodStub} }; methodDefinition *definitions[] = {definitions1, definitions2, definitions3,