Index: ChangeLog =================================================================== diff -u -rbb3a2bff37e7e5ca2ea59f19ae3ed5e6966b37b4 -rf37d836d9b24c8cdf9a44b29da6a2bd92dfd3716 --- ChangeLog (.../ChangeLog) (revision bb3a2bff37e7e5ca2ea59f19ae3ed5e6966b37b4) +++ ChangeLog (.../ChangeLog) (revision f37d836d9b24c8cdf9a44b29da6a2bd92dfd3716) @@ -1,3 +1,70 @@ +2008-02-04: + * Potential incompatibility: + provide a uniform interface to the following info subcommands + + info superclass ?-closure? ?pattern? + info subclass ?-closure? ?pattern? + info instances ?-closure? ?pattern? + info instmixinof ?-closure? ?pattern? + info mixinof ?pattern? + + In cases, where the option "-closure" is defined, + the values are computed transitively. + + In cases, where a pattern is specified, and + the pattern contains meta-characters, a list + of results is returned matching the pattern + (like "string match"). When no matching value + is found, an empty list is returned. + + In cases, where a pattern is specified, and + the pattern contains no meta-characters, + a single value is returned korrespinding to + the specified value. The pattern is used + to lookup an object or class, such it is + not necessary to provide fully qualified names). + if there is no match, empty is returned. + Previously, "info superclass" and "info subclass" + returned a boolean value and performed + always a transitive search. Returning "" + is more consistent and more in line with Tcl. + + By using the option "-closure" one can + perform the lookup in the transitive + or in the intransitive sets. + + Still to do: + children + parent + classchildren + classparent + +2008-02-03: + - fix getAllSubClasses + - fix "info mixinof -closure", when pattern was provided + - streamline code (AppendMatchingElement) + - new info option "-closure" for "info instances" (equiv. to "allinstances", but 5 times faster) + - new info option "-closure" for "info superclass" (equiv. to "info heritage") + +2008-02-02: + - Improving regression test: + + added ::xotcl::test::case + + shortended output + - Makefile.in: added missing src_man_dir + - fixed softcrecreate cases: + * update caches for subclasses of recreated classes + * fixed recreate when it defines different superclasses + * extended test cases for mixinoftest + +2008-02-01: + - Add closure option to mixinofinfo + - Enhance getAllClassMixinofs + +2008-01-23: + - saving object->id in cl->opt->id (probably a temporary solution) + - improving reset of affected objects, when (transitive) per class mixins change + - extended regression test + 2008-01-07: - don't call unset traces during an object move (related to fix below) Index: generic/predefined.h =================================================================== diff -u -rb872864b1f6375c55cf561c9e25335951f1386cf -rf37d836d9b24c8cdf9a44b29da6a2bd92dfd3716 --- generic/predefined.h (.../predefined.h) (revision b872864b1f6375c55cf561c9e25335951f1386cf) +++ generic/predefined.h (.../predefined.h) (revision f37d836d9b24c8cdf9a44b29da6a2bd92dfd3716) @@ -262,10 +262,7 @@ "if {[::xotcl::my ismixin $cl]} {return 1}\n" "::xotcl::my istype $cl}\n" "::xotcl::Class instproc allinstances {} {\n" -"set set [::xotcl::my info instances]\n" -"foreach sc [::xotcl::my info subclass] {\n" -"eval lappend set [$sc allinstances]}\n" -"return $set}\n" +"return [::xotcl::my info instances -closure]}\n" "::xotcl::Object proc unsetExitHandler {} {\n" "::xotcl::Object proc __exitHandler {} {\n" ";}}\n" Index: generic/predefined.xotcl =================================================================== diff -u -rb872864b1f6375c55cf561c9e25335951f1386cf -rf37d836d9b24c8cdf9a44b29da6a2bd92dfd3716 --- generic/predefined.xotcl (.../predefined.xotcl) (revision b872864b1f6375c55cf561c9e25335951f1386cf) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision f37d836d9b24c8cdf9a44b29da6a2bd92dfd3716) @@ -430,11 +430,8 @@ ::xotcl::my istype $cl } ::xotcl::Class instproc allinstances {} { - set set [::xotcl::my info instances] - foreach sc [::xotcl::my info subclass] { - eval lappend set [$sc allinstances] - } - return $set + # TODO: mark it deprecated + return [::xotcl::my info instances -closure] } Index: generic/xotcl.c =================================================================== diff -u -r1dd45310fe7b6df0c1ac61596f28a84d4ddadfbd -rf37d836d9b24c8cdf9a44b29da6a2bd92dfd3716 --- generic/xotcl.c (.../xotcl.c) (revision 1dd45310fe7b6df0c1ac61596f28a84d4ddadfbd) +++ generic/xotcl.c (.../xotcl.c) (revision f37d836d9b24c8cdf9a44b29da6a2bd92dfd3716) @@ -1280,6 +1280,20 @@ } } +/* reverse class list, caller is responsible for freeing data */ +static XOTclClasses* +XOTclReverseClasses(XOTclClasses *sl) { + XOTclClasses *first = NULL; + for (; sl; sl = sl->next) { + XOTclClasses *element = NEW(XOTclClasses); + element->cl = sl->cl; + element->clientData = sl->clientData; + element->next = first; + first = element; + } + return first; +} + extern XOTclClasses** XOTclAddClass(XOTclClasses **cList, XOTclClass *cl, ClientData cd) { XOTclClasses *l = *cList, *element = NEW(XOTclClasses); @@ -3221,37 +3235,76 @@ /* * apply AppendMatchingElement to CmdList */ -static void -AppendMatchingElementFromCmdList(Tcl_Interp *interp, XOTclCmdList *cmdl, char *pattern) { +static int +AppendMatchingElementsFromCmdList(Tcl_Interp *interp, XOTclCmdList *cmdl, + char *pattern, XOTclObject *matchObject) { + int rc = 0; for ( ; cmdl; cmdl = cmdl->next) { XOTclObject *obj = XOTclGetObjectFromCmdPtr(cmdl->cmdPtr); if (obj) { - AppendMatchingElement(interp, obj->cmdName, pattern); + if (matchObject == obj) { + return 1; + } else { + AppendMatchingElement(interp, obj->cmdName, pattern); + } } } + return rc; } /* + * apply AppendMatchingElement to + */ +static int +AppendMatchingElementsFromClasses(Tcl_Interp *interp, XOTclClasses *cls, + char *pattern, XOTclObject *matchObject) { + int rc = 0; + + for ( ; cls; cls = cls->next) { + XOTclObject *obj = (XOTclObject *)cls->cl; + if (obj) { + if (matchObject && obj == matchObject) { + /* we have a matchObject and it is identical to obj, + just return true and don't continue search + */ + return 1; + break; + } else { + AppendMatchingElement(interp, obj->cmdName, pattern); + } + } + } + return rc; +} + +/* * get all instances of a class recursively into an initialized * String key hashtable */ -static void -listInstances(Tcl_Interp *interp, XOTclClass *startCl, char *pattern, int closure) { +static int +listInstances(Tcl_Interp *interp, XOTclClass *startCl, + char *pattern, int closure, XOTclObject *matchObject) { Tcl_HashTable *table = &startCl->instances; XOTclClasses *sc; Tcl_HashSearch search; Tcl_HashEntry *hPtr; + int rc = 0; for (hPtr = Tcl_FirstHashEntry(table, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { XOTclObject *inst = (XOTclObject*) Tcl_GetHashKey(table, hPtr); + if (matchObject && inst == matchObject) { + return 1; + } AppendMatchingElement(interp, inst->cmdName, pattern); } if (closure) { for (sc = startCl->sub; sc; sc = sc->next) { - listInstances(interp, sc->cl, pattern, closure); + rc = listInstances(interp, sc->cl, pattern, closure, matchObject); + if (rc) break; } } + return rc; } @@ -3286,33 +3339,42 @@ * object ptr hashtable (TCL_ONE_WORD_KEYS) */ -static void -getAllSubClasses(Tcl_Interp *interp, Tcl_HashTable *destTable, - XOTclClass *startCl, int appendResult, char *pattern) { +static int +getAllSubClasses(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int appendResult, char *pattern, XOTclObject *matchObject) { XOTclClasses *sc; + int rc = 0; for (sc = startCl->sub; sc; sc = sc->next) { if (sc->cl) { int new; + if (matchObject && (XOTclObject *)sc->cl == matchObject) { + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + return 1; + } Tcl_CreateHashEntry(destTable, (char *)sc->cl, &new); if (new) { if (appendResult) { AppendMatchingElement(interp, sc->cl->object.cmdName, pattern); } - getAllSubClasses(interp, destTable, sc->cl, appendResult, pattern); + rc = getAllSubClasses(interp, destTable, sc->cl, appendResult, pattern, matchObject); + if (rc == 1) break; } } } + return rc; } /* * recursively get all isClassMixinOf of a class into an initialized * object ptr hashtable (TCL_ONE_WORD_KEYS) */ -static void -getAllClassMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, - XOTclClass *startCl, int appendResult, char *pattern) { +static int +getAllClassMixinsOf(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int appendResult, char *pattern, XOTclObject *matchObject) { + int rc = 0; + if (startCl->opt) { XOTclCmdList *m; @@ -3325,20 +3387,26 @@ cl = XOTclGetClassFromCmdPtr(m->cmdPtr); if (cl) { int new; + if (matchObject && matchObject == (XOTclObject *)cl) { + return 1; + } Tcl_CreateHashEntry(destTable, (char *)cl, &new); if (new) { /* if (new) fprintf (stderr, " -- %s (%s)\n", Tcl_GetCommandName(interp, m->cmdPtr), ObjStr(startCl->object.cmdName));*/ if (appendResult) { AppendMatchingElement(interp, cl->object.cmdName, pattern); } if (cl->sub) { - getAllSubClasses(interp, destTable, cl, appendResult, pattern); + rc = getAllSubClasses(interp, destTable, cl, appendResult, pattern, matchObject); + if (rc) {return rc;} } - getAllClassMixinsOf(interp, destTable, cl, appendResult, pattern); + rc = getAllClassMixinsOf(interp, destTable, cl, appendResult, pattern, matchObject); + if (rc) {return rc;} } } } } + return rc; } static void @@ -3500,7 +3568,7 @@ */ Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); - getAllClassMixinsOf(interp, commandTable, cl, 0, NULL); + getAllClassMixinsOf(interp, commandTable, cl, 0, NULL, NULL); for (hPtr = Tcl_FirstHashEntry(commandTable, &hSrch); hPtr; hPtr = Tcl_NextHashEntry(&hSrch)) { @@ -5830,6 +5898,24 @@ } static int +getMatchObject(Tcl_Interp *interp, char **pattern, XOTclObject **matchObject) { + if (*pattern && noMetaChars(*pattern)) { + *matchObject = XOTclpGetObject(interp, *pattern); + if (*matchObject) { + *pattern = ObjStr((*matchObject)->cmdName); + return 1; + } else { + /* not found */ + Tcl_SetObjResult(interp, XOTclGlobalObjects[XOTE_EMPTY]); + return -1; + } + } else { + *matchObject = NULL; + } + return 0; +} + +static int ListKeys(Tcl_Interp *interp, Tcl_HashTable *table, char *pattern) { Tcl_HashEntry *hPtr; char *key; @@ -6103,89 +6189,6 @@ } static int -ListSuperclasses(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { - if (pattern == NULL) { - XOTclClasses *sl = cl->super; - XOTclClasses *sc = 0; - - /* - * reverse the list to obtain presentation order - */ - - Tcl_ResetResult(interp); - while (sc != sl) { - XOTclClasses *nl = sl; - while (nl->next != sc) nl = nl->next; - Tcl_AppendElement(interp, className(nl->cl)); - sc = nl; - } - } else { - XOTclClass *isc = XOTclpGetClass(interp, pattern); - XOTclClasses *pl; - if (isc == 0) { - /* return XOTclErrBadVal(interp, "info superclass", "a class", pattern);*/ - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } else { - - /* - * search precedence to see if we're related or not - */ - for (pl = ComputeOrder(cl, cl->order, Super); pl; pl = pl->next) { - if (pl->cl == isc) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - break; - } - } - if (pl == 0) - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - } - } - return TCL_OK; -} - -static int -ListSubclasses(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { - if (pattern == NULL) { - XOTclClasses *sl = cl->sub; - XOTclClasses *sc = 0; - - /* - * order unimportant - */ - Tcl_ResetResult(interp); - for (sc = sl; sc != 0; sc = sc->next) - Tcl_AppendElement(interp, className(sc->cl)); - } else { - XOTclClass *isc = XOTclpGetClass(interp, pattern); - XOTclClasses *pl; - XOTclClasses *saved; - - if (isc == 0) - return XOTclErrBadVal(interp, "info subclass", "a class", pattern); - saved = cl->order; - cl->order = 0; - - /* - * search precedence to see if we're related or not - */ - for (pl = ComputeOrder(cl, cl->order, Sub); pl; pl = pl->next) { - if (pl->cl == isc) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); - break; - } - } - if (pl == 0) - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); - - XOTclFreeClasses(cl->order); - cl->order = saved; - } - return TCL_OK; -} - - - -static int ListHeritage(Tcl_Interp *interp, XOTclClass *cl, char *pattern) { XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); Tcl_ResetResult(interp); @@ -10569,7 +10572,8 @@ switch (*cmdTail) { case 'a': if (!strcmp(cmdTail, "ances")) { - int withClosure = 0; + int withClosure = 0, rc; + XOTclObject *matchObject; if (objc-modifiers > 3 || modifiers > 1) return XOTclObjErrArgCnt(interp, cl->object.cmdName, @@ -10580,7 +10584,15 @@ return XOTclVarErrMsg(interp, "info instances: unknown modifier ", ObjStr(objv[2]), (char *) NULL); } - listInstances(interp, cl, pattern, withClosure); + + if (getMatchObject(interp, &pattern, &matchObject) == -1) { + return TCL_OK; + } + + rc = listInstances(interp, cl, pattern, withClosure, matchObject); + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } return TCL_OK; } else if (!strcmp(cmdTail, "args")) { if (objc != 3 || modifiers > 0) @@ -10696,7 +10708,8 @@ return opt ? MixinInfo(interp, opt->instmixins, pattern, withGuards) : TCL_OK; } else if (!strcmp(cmdTail, "mixinof")) { - int withClosure = 0; + int withClosure = 0, rc; + XOTclObject *matchObject; if (objc-modifiers > 3 || modifiers > 1) return XOTclObjErrArgCnt(interp, cl->object.cmdName, @@ -10709,16 +10722,23 @@ } if (opt) { + if (getMatchObject(interp, &pattern, &matchObject) == -1) { + return TCL_OK; + } if (withClosure) { Tcl_HashTable objTable, *commandTable = &objTable; MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); - getAllClassMixinsOf(interp, commandTable, cl, 1, pattern); + rc = getAllClassMixinsOf(interp, commandTable, cl, 1, pattern, matchObject); MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); } else { - AppendMatchingElementFromCmdList(interp, opt->isClassMixinOf, pattern); + rc = AppendMatchingElementsFromCmdList(interp, opt->isClassMixinOf, + pattern, matchObject); } } + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } return TCL_OK; } else if (!strcmp(cmdTail, "mixinguard")) { @@ -10780,11 +10800,20 @@ case 'm': if (!strcmp(cmd, "mixinof")) { + XOTclObject *matchObject; + int rc; if (objc-modifiers > 3 || modifiers > 0) return XOTclObjErrArgCnt(interp, cl->object.cmdName, - "info mixinof ?object?"); - if (opt) - AppendMatchingElementFromCmdList(interp, opt->isObjectMixinOf, pattern); + "info mixinof ?pattern?"); + if (opt) { + if (getMatchObject(interp, &pattern, &matchObject) == -1) { + return TCL_OK; + } + rc = AppendMatchingElementsFromCmdList(interp, opt->isObjectMixinOf, pattern, matchObject); + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + } return TCL_OK; } break; @@ -10835,24 +10864,70 @@ case 's': if (!strcmp(cmd, "superclass")) { - int withClosure = 0; - if (objc > 3 || modifiers > 1) + int withClosure = 0, rc; + XOTclObject *matchObject; + if (objc-modifiers > 3 || modifiers > 1) return XOTclObjErrArgCnt(interp, cl->object.cmdName, - "info superclass ?-closure? ?class?"); + "info superclass ?-closure? ?pattern?"); if (modifiers > 0) { withClosure = checkForModifier(objv, modifiers, "-closure"); if (withClosure == 0) return XOTclVarErrMsg(interp, "info superclass: unknown modifier ", ObjStr(objv[2]), (char *) NULL); - return ListHeritage(interp, cl, pattern); + } + + if (getMatchObject(interp, &pattern, &matchObject) == -1) { + return TCL_OK; + } + + if (withClosure) { + XOTclClasses *pl = ComputeOrder(cl, cl->order, Super); + if (pl) pl=pl->next; + rc = AppendMatchingElementsFromClasses(interp, pl, pattern, matchObject); } else { - return ListSuperclasses(interp, cl, pattern); + XOTclClasses *clSuper = XOTclReverseClasses(cl->super); + rc = AppendMatchingElementsFromClasses(interp, clSuper, pattern, matchObject); + XOTclFreeClasses(clSuper); } + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + return TCL_OK; + } else if (!strcmp(cmd, "subclass")) { - if (objc > 3 || modifiers > 0) + int withClosure = 0, rc; + XOTclObject *matchObject; + + if (objc-modifiers > 3 || modifiers > 1) return XOTclObjErrArgCnt(interp, cl->object.cmdName, - "info subclass ?class?"); - return ListSubclasses(interp, cl, pattern); + "info subclass ?-closure? ?pattern?"); + if (modifiers > 0) { + withClosure = checkForModifier(objv, modifiers, "-closure"); + if (withClosure == 0) + return XOTclVarErrMsg(interp, "info subclass: unknown modifier ", + ObjStr(objv[2]), (char *) NULL); + } + + if (getMatchObject(interp, &pattern, &matchObject) == -1) { + return TCL_OK; + } + + if (withClosure) { + XOTclClasses *saved = cl->order, *subclasses; + cl->order = 0; + subclasses = ComputeOrder(cl, cl->order, Sub); + cl->order = saved; + if (subclasses) subclasses=subclasses->next; + rc = AppendMatchingElementsFromClasses(interp, subclasses, pattern, matchObject); + XOTclFreeClasses(subclasses); + } else { + rc = AppendMatchingElementsFromClasses(interp, cl->sub, pattern, matchObject); + } + if (matchObject) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + return TCL_OK; + } else if (!strcmp(cmd, "slots")) { Tcl_DString ds, *dsPtr = &ds; XOTclObject *o; Index: tests/speedtest.xotcl =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -rf37d836d9b24c8cdf9a44b29da6a2bd92dfd3716 --- tests/speedtest.xotcl (.../speedtest.xotcl) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ tests/speedtest.xotcl (.../speedtest.xotcl) (revision f37d836d9b24c8cdf9a44b29da6a2bd92dfd3716) @@ -253,7 +253,9 @@ Test new -cmd {llength [Object info instances]} -expected 1007 } +Test new -cmd {Object info instances ::c::500*} -expected ::c::500 Test new -cmd {Object info instances ::c::500} -expected ::c::500 +Test new -cmd {Object info instances ::c::5000} -expected "" Test new -count 100 -pre {set ::c::l ""} \ -cmd {lappend ::c::l 1} \ Index: tests/testo.xotcl =================================================================== diff -u -rc72f9f638677608fab1502cd696c8f2d6b2952f9 -rf37d836d9b24c8cdf9a44b29da6a2bd92dfd3716 --- tests/testo.xotcl (.../testo.xotcl) (revision c72f9f638677608fab1502cd696c8f2d6b2952f9) +++ tests/testo.xotcl (.../testo.xotcl) (revision f37d836d9b24c8cdf9a44b29da6a2bd92dfd3716) @@ -182,7 +182,6 @@ # factors become subclasses, direct or indirect # - if {[TestClass info instances $i] eq ""} then { my factorgraph $i $i superclass $n Index: tests/testx.xotcl =================================================================== diff -u -r18e8dcd86f6ff86326697306e4e60db5e59011c7 -rf37d836d9b24c8cdf9a44b29da6a2bd92dfd3716 --- tests/testx.xotcl (.../testx.xotcl) (revision 18e8dcd86f6ff86326697306e4e60db5e59011c7) +++ tests/testx.xotcl (.../testx.xotcl) (revision f37d836d9b24c8cdf9a44b29da6a2bd92dfd3716) @@ -3130,16 +3130,18 @@ ::errorCheck [Class info instances Unk*] "" "no match in info instances" ::errorCheck [Class info instances Unk] "" "no match in info instances (no metachars)" ::errorCheck [Class info class] ::xotcl::Class "info class of Class" - ::errorCheck [Class info class Object] 1 "info class of Class Object" + ::errorCheck [Class info class Object] ::xotcl::Object "info class of Class Object" Class C Class D -superclass C Class E -superclass D -parameter {{x 1}} E instproc t {a b {c 1}} {return ok} E proc p {a b {c 1}} {return ok} E instproc q {} {return [self proc]} - ::errorCheck [C info subclass E] 1 "transitive subclass 1" - ::errorCheck [Object info subclass E] 1 "transitive subclass 2" - ::errorCheck [D info subclass C] 0 "transitive subclass 3" + ::errorCheck [C info subclass D] ::D "transitive subclass 0" + ::errorCheck [C info subclass E] "" "transitive subclass 0a" + ::errorCheck [C info subclass -closure E] ::E "transitive subclass 1" + ::errorCheck [Object info subclass -closure E] ::E "transitive subclass 2" + ::errorCheck [D info subclass -closure C] "" "transitive subclass 3" ::errorCheck [E info heritage] "::D ::C ::xotcl::Object" "heritage" ::errorCheck [E info instargs t] "a b c" "instargs" ::errorCheck [E info instdefault t c x] 1 "instdefault"