Index: ChangeLog =================================================================== diff -u -r90f13fe04f5c707be3b56808a8a7992adab1855f -r570b5b8ea87572bdfd1460842ac333359800467b --- ChangeLog (.../ChangeLog) (revision 90f13fe04f5c707be3b56808a8a7992adab1855f) +++ ChangeLog (.../ChangeLog) (revision 570b5b8ea87572bdfd1460842ac333359800467b) @@ -1,3 +1,9 @@ +2008-02-08: + * New info option "-closure" for "info instmixin" with + -guards and -closure support + + * Extended test cases for "info instmixin" + 2008-02-06: * Continued with info orthogonality change @@ -8,10 +14,6 @@ ago. Preceding colons in the name of the queried class are not required. - Still to do "-closure" in - - info instmixin -closure ?pattern? - * In all mentioned calls, where pattern refers to an object/class and it contains wild-cards, a preceding :: is added automatically to the search pattern, if it is missing. Since all object names @@ -2426,7 +2428,7 @@ * finished polishing mem leaks (thanks to Zoran Vasiljevic again) * disallowed "[self] next" ... next is now only a command * Gdbm,Sdbm,Expat: corrected Makefile.in to rely on - -L$(TCLLIBDIR) (thanks to J�rg Rudnik for the hint) + -L$(TCLLIBDIR) (thanks to Jrg Rudnik for the hint) 2001-10-08 * configure.in: fixes for AOLSERVER to ease configuration Index: generic/xotcl.c =================================================================== diff -u -r90f13fe04f5c707be3b56808a8a7992adab1855f -r570b5b8ea87572bdfd1460842ac333359800467b --- generic/xotcl.c (.../xotcl.c) (revision 90f13fe04f5c707be3b56808a8a7992adab1855f) +++ generic/xotcl.c (.../xotcl.c) (revision 570b5b8ea87572bdfd1460842ac333359800467b) @@ -3355,6 +3355,34 @@ } /* + * helper function for getAllClassMixins to add classes with guards + * to the result set, flagging test for matchObject as result + */ + +static int +addToResultSetWithGuards(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *cl, ClientData clientData, int *new, + int appendResult, char *pattern, XOTclObject *matchObject) { + Tcl_CreateHashEntry(destTable, (char *)cl, new); + if (*new) { + if (appendResult) { + if (!pattern || Tcl_StringMatch(ObjStr(cl->object.cmdName), pattern)) { + Tcl_Obj *l = Tcl_NewListObj(0, NULL); + Tcl_Obj *g = (Tcl_Obj*) clientData; + Tcl_ListObjAppendElement(interp, l, cl->object.cmdName); + Tcl_ListObjAppendElement(interp, l, XOTclGlobalObjects[XOTE_GUARD_OPTION]); + Tcl_ListObjAppendElement(interp, l, g); + Tcl_AppendElement(interp, ObjStr(l)); + DECR_REF_COUNT(l); + } + } + if (matchObject && matchObject == (XOTclObject *)cl) { + return 1; + } + } + return 0; +} + +/* * recursively get all isClassMixinOf of a class into an initialized * object ptr hashtable (TCL_ONE_WORD_KEYS) */ @@ -3413,6 +3441,64 @@ return rc; } +/* + * recursively get all instmixins of a class into an initialized + * object ptr hashtable (TCL_ONE_WORD_KEYS) + */ + +static int +getAllClassMixins(Tcl_Interp *interp, Tcl_HashTable *destTable, XOTclClass *startCl, + int withGuards, char *pattern, XOTclObject *matchObject) { + int rc = 0, new = 0; + XOTclClass *cl; + XOTclClasses *sc; + + /* + * check this class for instmixins + */ + if (startCl->opt) { + XOTclCmdList *m; + + for (m = startCl->opt->instmixins; m; m = m->next) { + + /* we should have no deleted commands in the list */ + assert(Tcl_Command_cmdEpoch(m->cmdPtr) == 0); + + cl = XOTclGetClassFromCmdPtr(m->cmdPtr); + assert(cl); + + /* fprintf(stderr,"Instmixin found: %s\n", ObjStr(cl->object.cmdName)); */ + + if ((withGuards) && (m->clientData)) { + /* fprintf(stderr,"addToResultSetWithGuards: %s\n", ObjStr(cl->object.cmdName)); */ + rc = addToResultSetWithGuards(interp, destTable, cl, m->clientData, &new, 1, pattern, matchObject); + } else { + /* fprintf(stderr,"addToResultSet: %s\n", ObjStr(cl->object.cmdName)); */ + rc = addToResultSet(interp, destTable, cl, &new, 1, pattern, matchObject); + } + if (rc == 1) {return rc;} + + if (new) { + /* fprintf(stderr,"Instmixin getAllClassMixins for: %s (%s)\n",ObjStr(cl->object.cmdName),ObjStr(startCl->object.cmdName)); */ + rc = getAllClassMixins(interp, destTable, cl, withGuards, pattern, matchObject); + if (rc) {return rc;} + } + } + } + + + /* + * check all superclasses of startCl for instmixins + */ + for (sc = startCl->super; sc; sc = sc->next) { + /* fprintf(stderr,"Superclass getAllClassMixins for %s (%s)\n",ObjStr(sc->cl->object.cmdName),ObjStr(startCl->object.cmdName)); */ + rc = getAllClassMixins(interp, destTable, sc->cl, withGuards, pattern, matchObject); + if (rc) {return rc;} + } + return rc; +} + + static void RemoveFromClassMixinsOf(Tcl_Command cmd, XOTclCmdList *cmdlist) { @@ -10733,27 +10819,41 @@ case 'm': if (!strcmp(cmdTail, "mixin")) { - int withGuards = 0, rc; + int withClosure = 0, withGuards = 0, rc; XOTclObject *matchObject; Tcl_DString ds, *dsPtr = &ds; - if (objc-modifiers > 3 || modifiers > 1) + if (objc-modifiers > 3 || modifiers > 2) return XOTclObjErrArgCnt(interp, cl->object.cmdName, - "info instmixin ?-guards? ?pattern?"); + "info instmixin ?-closure? ?-guards? ?pattern?"); if (modifiers > 0) { withGuards = checkForModifier(objv, modifiers, "-guards"); - if (withGuards == 0) + withClosure = checkForModifier(objv, modifiers, "-closure"); + if ((withGuards == 0) && (withClosure == 0)) return XOTclVarErrMsg(interp, "info instfilter: unknown modifier ", ObjStr(objv[2]), (char *) NULL); } - DSTRING_INIT(dsPtr); - if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { - return TCL_OK; - } - rc = opt ? MixinInfo(interp, opt->instmixins, pattern, withGuards, matchObject) : TCL_OK; - DSTRING_FREE(dsPtr); - return rc; + if ((opt) || (withClosure)) { + DSTRING_INIT(dsPtr); + if (getMatchObject(interp, &pattern, &matchObject, dsPtr) == -1) { + return TCL_OK; + } + if (withClosure) { + Tcl_HashTable objTable, *commandTable = &objTable; + MEM_COUNT_ALLOC("Tcl_InitHashTable", commandTable); + Tcl_InitHashTable(commandTable, TCL_ONE_WORD_KEYS); + rc = getAllClassMixins(interp, commandTable, cl, withGuards, pattern, matchObject); + if (matchObject && rc && !withGuards) { + Tcl_SetObjResult(interp, rc ? matchObject->cmdName : XOTclGlobalObjects[XOTE_EMPTY]); + } + MEM_COUNT_FREE("Tcl_InitHashTable", commandTable); + } else { + rc = opt ? MixinInfo(interp, opt->instmixins, pattern, withGuards, matchObject) : TCL_OK; + } + DSTRING_FREE(dsPtr); + } + return TCL_OK; } else if (!strcmp(cmdTail, "mixinof")) { int withClosure = 0, rc; Index: tests/mixinoftest.xotcl =================================================================== diff -u -rb50baa47b65361cce5e09caa477fa065ce3e0826 -r570b5b8ea87572bdfd1460842ac333359800467b --- tests/mixinoftest.xotcl (.../mixinoftest.xotcl) (revision b50baa47b65361cce5e09caa477fa065ce3e0826) +++ tests/mixinoftest.xotcl (.../mixinoftest.xotcl) (revision 570b5b8ea87572bdfd1460842ac333359800467b) @@ -68,6 +68,32 @@ c1 destroy ########################################### +# testing simple per class mixins with guards +########################################### +::xotcl::test::case pcm2 +Class M1 +Class M2 +Class X +Class A -instmixin {M1 M2 X} +A instmixinguard M1 "test" +Class B -superclass A +? {A info instmixin M2} ::M2 +? {A info instmixin M*} "::M1 ::M2" +? {A info instmixin -guards} "{::M1 -guard test} ::M2 ::X" +? {B info instmixin} "" +? {B info instmixin -closure} "::M1 ::M2 ::X" +? {B info instmixin -closure M2} ::M2 +? {B info instmixin -closure M*} "::M1 ::M2" +? {B info instmixin -closure -guards} "{::M1 -guard test} ::M2 ::X" +? {B info instmixin -closure -guards M1} "{::M1 -guard test}" +? {B info instmixin -closure -guards M*} "{::M1 -guard test} ::M2" +A destroy +B destroy +X destroy +M1 destroy +M2 destroy + +########################################### # testing transitive per class mixins ########################################### ::xotcl::test::case trans-pcm1 @@ -163,11 +189,6 @@ foreach o {A1 A2 A3 B0 B1 B2 B3 C1 C2 C3} {$o destroy} - - - - - ########################################### # testing transitive per class mixins with destroy ###########################################