Index: xotcl/ChangeLog =================================================================== diff -u -ra095dd118343e4b469b25c6801fd0de73192686c -rd374abc5db9d88ce09ee134350fac67ae0d59e5e --- xotcl/ChangeLog (.../ChangeLog) (revision a095dd118343e4b469b25c6801fd0de73192686c) +++ xotcl/ChangeLog (.../ChangeLog) (revision d374abc5db9d88ce09ee134350fac67ae0d59e5e) @@ -1,3 +1,40 @@ +2004-06-20 Gustaf.Neumann@wu-wien.ac.at + * second version of mkinstdelegator and mkdelegator + + A delegator method is defined via + Class instdelegator method COMMAND ARGS + a call to the defined method with some args + obj method arg1 arg2 arg3... + is mapped to + COMMAND ARGS arg1 INSERTTOKENS arg1 arg2... + + Class mkinstdelegator \ + ?-nocaller? \ + ?-skip nr_of_tokens? \ + ?-insert tokens? + ?-prefix string? \ + ?-defaultmethod subcommand? \ + + where + methodname: name of an instcommand for the class + to be registered, + commandname: command that recieves delegation + -nocaller: don't insert caller after method + -skip: skip n arguments from the call. "-skip 1" + means that not the "method" from the invocation is + used as the method call, but the first argument + -prefix: prefix, to be added in front of + called method (to avoid name clashes + with "set", etc.) + -insert: tokens to be inserted after the caller + + -defaultmethod: when number of arguments is not sufficient + to determine the called method, use the specified + value to be used as method name (only useful when + -skip is used und the arguments run out) + (e.g. [$obj info] be mapped to COMMAND showInfoOptions) + + 2004-06-18 Gustaf.Neumann@wu-wien.ac.at * added *.a to CLEANFILES in configure.in to rm stublibfile on a "make clean" @@ -21,27 +58,7 @@ 2004-05-29 Gustaf.Neumann@wu-wien.ac.at * first version of instdelegatecommand - Object instdelegatecmd \ - ?-defaultmethod subcommand? \ - ?-methodprefix string? \ - ?-insert tokens? - where - methodname: name of an instcommand for a class - to be registered, - commandname: command that recieves delegation - defaultmethod: when number of arguments is low, - allows for method to - be inserted (e.g. result of [$obj info], - which can be mapped to ::xotcl::info info) - methodprefix: prefix, to be added in front of - subcommand to avoidname clashes with "set", etc. - insert: tokens to be inserted. - A call to a delegated method - X method subcmd arg1 arg2... - can be mapped to - COMMANDNAME subcmd [self] INSERTTOKENS arg1 arg2... - * defined metaclass ::xotcl:.SelfApplicableClass to allow for instprocs of this class to be applicable for itself (useful for delegation objects) Index: xotcl/Makefile =================================================================== diff -u -ra095dd118343e4b469b25c6801fd0de73192686c -rd374abc5db9d88ce09ee134350fac67ae0d59e5e --- xotcl/Makefile (.../Makefile) (revision a095dd118343e4b469b25c6801fd0de73192686c) +++ xotcl/Makefile (.../Makefile) (revision d374abc5db9d88ce09ee134350fac67ae0d59e5e) @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: Makefile,v 1.5 2004/06/18 08:27:57 neumann Exp $ +# RCS: @(#) $Id: Makefile,v 1.6 2004/06/20 21:14:14 neumann Exp $ #======================================================================== # Add additional lines to handle any additional AC_SUBST cases that @@ -123,7 +123,7 @@ PACKAGE_NAME = xotcl PACKAGE_VERSION = 1.2.1 CC = gcc -pipe -CFLAGS_DEFAULT = -O +CFLAGS_DEFAULT = -O -g CFLAGS_WARNING = -Wall -Wconversion -Wno-implicit-int CLEANFILES = *.o *.a *.so *~ core gmon.out config.* EXEEXT = Index: xotcl/doc/langRef-xotcl.html =================================================================== diff -u -rf7894d9be99a8da3a04218abcdb9bd46b6d625c8 -rd374abc5db9d88ce09ee134350fac67ae0d59e5e --- xotcl/doc/langRef-xotcl.html (.../langRef-xotcl.html) (revision f7894d9be99a8da3a04218abcdb9bd46b6d625c8) +++ xotcl/doc/langRef-xotcl.html (.../langRef-xotcl.html) (revision d374abc5db9d88ce09ee134350fac67ae0d59e5e) @@ -121,7 +121,7 @@ Date: - $Date: 2004/05/23 22:50:39 $ + $Date: 2004/06/20 21:14:14 $ @@ -303,8 +303,11 @@ for classes. The following options can be specified:
    -
  • ClassName info classchildren: - Returns the list of nested classes with fully qualified names. +
  • ClassName info classchildren ?pattern?: + Returns the list of nested classes with fully qualified names + if pattern was not specified, + otherwise it returns all class children where the class name + matches the pattern.
  • ClassName info classparent: Returns the class ClassName is nesting to. @@ -2113,8 +2116,9 @@ not specified, otherwise it returns 1 if classname matches the object's class and 0 if not. -
  • objName info children: Returns the list of aggregated - objects with fully qualified names. +
  • objName info children ?pattern?: Returns the list of aggregated + objects with fully qualified names if pattern was not specified, + otherwise it returns all children where the object name matches the pattern.
  • objName info commands ?pattern: Returns all commands defined for the object if pattern was not specified, otherwise Index: xotcl/generic/xotcl.c =================================================================== diff -u -r37995b61f3522a362600738a765a4b38549e0a25 -rd374abc5db9d88ce09ee134350fac67ae0d59e5e --- xotcl/generic/xotcl.c (.../xotcl.c) (revision 37995b61f3522a362600738a765a4b38549e0a25) +++ xotcl/generic/xotcl.c (.../xotcl.c) (revision d374abc5db9d88ce09ee134350fac67ae0d59e5e) @@ -1,5 +1,5 @@ #define NAMESPACEINSTPROCS 1 -/* $Id: xotcl.c,v 1.3 2004/06/18 07:15:17 neumann Exp $ +/* $Id: xotcl.c,v 1.4 2004/06/20 21:14:14 neumann Exp $ * * XOTcl - Extended OTcl * @@ -113,12 +113,14 @@ typedef struct delegateCmdClientData { XOTcl_Object *obj; Tcl_Obj *cmdName; - Tcl_Obj *subcommands; + Tcl_Obj *args; + int skip; + int insertcaller; + Tcl_Obj *prefix; int nr_subcommands; - Tcl_Obj *inserts; + Tcl_Obj *subcommands; int nr_inserts; - Tcl_Obj *prefix; - + Tcl_Obj *inserts; } delegateCmdClientData; static int ObjDispatch(ClientData cd, Tcl_Interp *in, int objc, @@ -6943,71 +6945,120 @@ XOTclDelegateMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { delegateCmdClientData *tcd = (delegateCmdClientData *)cd; /*XOTcl_FrameDecls;*/ - int result, nrargs, i, j, offset = 1; + int result, nrargs, j, inputarg, outputarg=0, clientargs=0; if (!tcd || !tcd->obj) return XOTclObjErrType(in, objv[0], "Object"); + + if (tcd->args) Tcl_ListObjLength(in, tcd->args, &clientargs); + if (tcd->skip<0) {tcd->skip = tcd->args ? 1 : 0;} { - DEFINE_NEW_TCL_OBJS_ON_STACK(objc+ tcd->nr_inserts + 2, ov); - - RUNTIME_STATE(in)->cs.top->currentFramePtr = Tcl_Interp_varFramePtr(in); - /*XOTcl_PushFrame(in, tcd->obj);*/ + DEFINE_NEW_TCL_OBJS_ON_STACK(objc + clientargs + tcd->nr_inserts + 3, OV); + Tcl_Obj **ov=&OV[1]; + XOTclCallStackContent *top = RUNTIME_STATE(in)->cs.top; - i = 1; - ov[0] = tcd->cmdName; - GetXOTclObjectFromObj(in, tcd->cmdName, (void*)&cd); - nrargs = objc-1; + /* it is a c-method; establish a value for the currentFramePtr */ + top->currentFramePtr = Tcl_Interp_varFramePtr(in); + + if (tcd->skip > objc) return + XOTclObjErrArgCnt(in, objv[0], "skip value in delegation to large"); + + inputarg = tcd->skip; + nrargs = objc-inputarg; +#if 0 + fprintf(stderr,"delegator %s (%p) nrargs=%d, skip=%d, subcommand=%d, nr_inserts=%d args=%p\n", + ObjStr(objv[0]), tcd, nrargs, + tcd->skip, + tcd->nr_subcommands, + tcd->nr_inserts, + tcd->args + ); +#endif + + /* the first argument is always the command, to which we delegate */ + ov[outputarg++] = tcd->cmdName; + + if (tcd->args) { + /* copy argument list from definition */ + Tcl_Obj **listElements; + int nrElements; + Tcl_ListObjGetElements(in, tcd->args, &nrElements, &listElements); + + for (j=0; jnr_subcommands=%d size=%d\n", nrargs, objc, tcd->nr_subcommands, objc+ tcd->nr_inserts + 2 ); */ if (tcd->nr_subcommands > nrargs) { /* insert default subcommand depending on number of arguments */ - int rc = Tcl_ListObjIndex(in, tcd->subcommands, nrargs, &ov[1]); + int rc = Tcl_ListObjIndex(in, tcd->subcommands, nrargs, &ov[outputarg]); if (rc != TCL_OK) return rc; - /* fprintf(stderr,"subcommand(%d) = ov[%d] = %p\n", nrargs, 1, ov[1]); - */ - } else if (nrargs>0) { - /* we use the subcommand from the call */ - ov[1] = objv[1]; - offset++; + /*fprintf(stderr," subcommand(%d) = ov[%d] = '%s'\n", nrargs, outputarg, + ObjStr(ov[inputarg]));*/ + outputarg++; + + } else if (nrargs>0 && !tcd->args) { + /* we use the method from the call */ + /*fprintf(stderr, " using the method from the call %s [%d] on pos %d\n", + ObjStr(objv[inputarg]), inputarg, outputarg);*/ + ov[outputarg++] = objv[inputarg++]; + } + if (tcd->insertcaller) { + ov[outputarg++] = tcd->obj->cmdName; + /*ov[outputarg++] = top->self->cmdName;*/ + } + + /*fprintf(stderr, " nr_inserts=%d objv[0]=%p outputarg=%d\n", + tcd->nr_inserts, objv[0],outputarg);*/ + + for (j=0; j < tcd->nr_inserts; j++) { + int rc = Tcl_ListObjIndex(in, tcd->inserts, j, &ov[outputarg]); + if (rc != TCL_OK) + return rc; + outputarg ++; + } + if (objc-inputarg>0) { + /* fprintf(stderr, " copying remaining %d args starting at [%d]\n", + objc-inputarg, outputarg); */ + memcpy(ov+outputarg, objv+inputarg, sizeof(Tcl_Obj *)*(objc-inputarg)); + } else { + /* fprintf(stderr, " nothing to copy, objc=%d, inputarg=%d\n", objc, inputarg);*/ + } + objc = objc + outputarg - inputarg; + if (tcd->prefix) { /* prepend a prefix for the subcommands to avoid name clashes */ Tcl_Obj *methodName = Tcl_DuplicateObj(tcd->prefix); Tcl_AppendObjToObj(methodName, ov[1]); ov[1] = methodName; INCR_REF_COUNT(ov[1]); } - i = 2; - ov[i++] = tcd->obj->cmdName; - /* - fprintf(stderr, "nr_inserts=%d objv[0]=%p i=%d\n", - tcd->nr_inserts, objv[0],i); - */ - for (j=0; j < tcd->nr_inserts; j++) { - int rc = Tcl_ListObjIndex(in, tcd->inserts, j, &ov[i]); - if (rc != TCL_OK) - return rc; - i ++; + +#if 0 + for(j=0; jcmdName, (void*)&cd) == TCL_OK) { + result = DoDispatch(cd, in, objc, ov, 0); + } else { + /*fprintf(stderr, "no XOTcl object %s\n", ObjStr(tcd->cmdName));*/ + OV[0] = tcd->cmdName; + result = Tcl_EvalObjv(in, objc+1, OV, 0); + } if (tcd->prefix) { DECR_REF_COUNT(ov[1]); } - /*XOTcl_PopFrame(in, tcd->obj);*/ - FREE_TCL_OBJS_ON_STACK(ov); + FREE_TCL_OBJS_ON_STACK(OV); } return result; } @@ -8400,72 +8451,139 @@ static void delegateCmdDeleteProc(ClientData cd) { delegateCmdClientData *tcd = (delegateCmdClientData *)cd; - DECR_REF_COUNT(tcd->cmdName); - /* - fprintf(stderr, "inserts %d %p subcommands %d %p\n", - tcd->nr_inserts,tcd->inserts, - tcd->nr_subcommands, tcd->subcommands); - */ + if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} if (tcd->inserts) {DECR_REF_COUNT(tcd->inserts);} if (tcd->subcommands) {DECR_REF_COUNT(tcd->subcommands);} if (tcd->prefix) {DECR_REF_COUNT(tcd->prefix);} + if (tcd->args) {DECR_REF_COUNT(tcd->args);} FREE(delegateCmdClientData, tcd); } + static int -XOTclCInstDelegateCmdMethod(ClientData cd, Tcl_Interp *in, - int objc, Tcl_Obj * CONST objv[]) { - XOTclClass *cl = XOTclObjectToClass(cd); +delegateProcessOption(Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[], + delegateCmdClientData **tcdp) { delegateCmdClientData *tcd; - char *cmdName; int i, rc; - if (!cl) return XOTclObjErrType(in, objv[0], "Class"); - if (objc < 2) goto delegate_argc_error; - - cmdName = ObjStr(objv[1]); + rc = 0; tcd = NEW(delegateCmdClientData); - tcd->obj = (XOTcl_Object*)cl; - tcd->cmdName = objv[2]; - INCR_REF_COUNT(tcd->cmdName); + tcd->cmdName = 0; + tcd->args = 0; tcd->nr_subcommands = 0; tcd->subcommands = 0; tcd->nr_inserts = 0; tcd->inserts = 0; tcd->prefix = 0; - for (i=3; iinsertcaller = 1; + tcd->skip = -1; /* not specified */ + for (i=2; isubcommands = objv[i+1]; rc = Tcl_ListObjLength(in,objv[i+1],&tcd->nr_subcommands); - if (rc != TCL_OK) - return rc; + if (rc != TCL_OK) break; INCR_REF_COUNT(tcd->subcommands); + i++; } else if (!strcmp(ObjStr(objv[i]),"-insert")) { - if (objcinserts = objv[i+1]; rc = Tcl_ListObjLength(in,objv[i+1],&tcd->nr_inserts); - if (rc != TCL_OK) - return rc; + if (rc != TCL_OK) break; INCR_REF_COUNT(tcd->inserts); - } else if (!strcmp(ObjStr(objv[i]),"-methodprefix")) { - if (objcprefix = objv[i+1]; INCR_REF_COUNT(tcd->prefix); + i++; + } else if (!strcmp(ObjStr(objv[i]),"-skip")) { + int result; + if (objc <= i+1) {rc = TCL_ERROR; break;} + result = Tcl_GetIntFromObj(in, objv[i+1], &(tcd->skip)); + if (result != TCL_OK) return result; + i++; + } else if (!strcmp(ObjStr(objv[i]),"-nocaller")) { + tcd->insertcaller = 0; + } else { + if (tcd->cmdName == 0) { + tcd->cmdName = objv[2]; + } else if (tcd->args == 0) { + tcd->args = Tcl_NewListObj(1, &objv[i]); + INCR_REF_COUNT(tcd->args); + } else { + Tcl_ListObjAppendElement(in, tcd->args, objv[i]); + } } } - XOTclAddIMethod(in, (XOTcl_Class*) cl, NSTail(cmdName), - (Tcl_ObjCmdProc*)XOTclDelegateMethod, - (ClientData)tcd, delegateCmdDeleteProc); - return TCL_OK; - delegate_argc_error: - return XOTclObjErrArgCnt(in, cl->object.cmdName, - "instdelegatecmd procname callname ?-defaultmethod name? ?-insert tokens? ?-methodprefix string?"); + if (!tcd->cmdName) + tcd->cmdName = objv[1]; + + INCR_REF_COUNT(tcd->cmdName); + + if (rc == TCL_OK) { + *tcdp = tcd; + } else { + delegateCmdDeleteProc((ClientData)tcd); + } + return rc; } static int +XOTclCInstDelegateCmdMethod(ClientData cd, Tcl_Interp *in, + int objc, Tcl_Obj * CONST objv[]) { + XOTclClass *cl = XOTclObjectToClass(cd); + delegateCmdClientData *tcd; + int rc; + + if (!cl) return XOTclObjErrType(in, objv[0], "Class"); + if (objc < 2) goto delegate_argc_error; + + rc = delegateProcessOption(in, objc, objv, &tcd); + + if (rc == TCL_OK) { + tcd->obj = (XOTcl_Object*)cl; + XOTclAddIMethod(in, (XOTcl_Class*) cl, NSTail(ObjStr(objv[1])), + (Tcl_ObjCmdProc*)XOTclDelegateMethod, + (ClientData)tcd, delegateCmdDeleteProc); + return TCL_OK; + } else { + delegate_argc_error: + return XOTclObjErrArgCnt(in, cl->object.cmdName, + "mkinstdelegator method obj ?args? ?-defaultmethod name? ?-insert tokens? ?-prefix string? ?-skip #? ?-nocaller?"); + } +} + +static int +XOTclCDelegateCmdMethod(ClientData cd, Tcl_Interp *in, + int objc, Tcl_Obj * CONST objv[]) { + XOTcl_Object *obj = (XOTcl_Object*) cd; + delegateCmdClientData *tcd; + int rc; + + if (!obj) return XOTclObjErrType(in, objv[0], "Object"); + if (objc < 2) goto delegate_argc_error; + + rc = delegateProcessOption(in, objc, objv, &tcd); + + if (rc == TCL_OK) { + tcd->obj = obj; + XOTclAddPMethod(in, obj, NSTail(ObjStr(objv[1])), + (Tcl_ObjCmdProc*)XOTclDelegateMethod, + (ClientData)tcd, delegateCmdDeleteProc); + return TCL_OK; + } else { + delegate_argc_error: + return XOTclObjErrArgCnt(in, obj->cmdName, + "mkdelegator method obj ?args? ?-defaultmethod name? ?-insert tokens? ?-prefix string? ?-skip #? ?-nocaller?"); + } +} + + +static int XOTclCVolatileMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { XOTclObject *obj = (XOTclObject*) cd; Tcl_Obj *o = obj->cmdName; @@ -9639,6 +9757,7 @@ #endif XOTclAddIMethod(in, (XOTcl_Class*) theobj, "mixin", (Tcl_ObjCmdProc*)XOTclOMixinMethod, 0, 0); XOTclAddIMethod(in, (XOTcl_Class*) theobj, "mixinguard", (Tcl_ObjCmdProc*)XOTclOMixinGuardMethod, 0, 0); + XOTclAddIMethod(in, (XOTcl_Class*) theobj, "mkdelegator", (Tcl_ObjCmdProc*)XOTclCDelegateCmdMethod, 0, 0); XOTclAddIMethod(in, (XOTcl_Class*) theobj, "__next", (Tcl_ObjCmdProc*)XOTclONextMethod, 0, 0); XOTclAddIMethod(in, (XOTcl_Class*) theobj, "noinit", (Tcl_ObjCmdProc*)XOTclONoinitMethod, 0, 0); XOTclAddIMethod(in, (XOTcl_Class*) theobj, "parametercmd", (Tcl_ObjCmdProc*)XOTclCParameterCmdMethod, 0, 0); @@ -9668,7 +9787,7 @@ XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instparametercmd", (Tcl_ObjCmdProc*)XOTclCInstParameterCmdMethod, 0, 0); XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instproc", (Tcl_ObjCmdProc*)XOTclCInstProcMethod, 0, 0); XOTclAddIMethod(in, (XOTcl_Class*) thecls, "insttclcmd", (Tcl_ObjCmdProc*)XOTclCInstTclCmdMethod, 0, 0); - XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instdelegatecmd", (Tcl_ObjCmdProc*)XOTclCInstDelegateCmdMethod, 0, 0); + XOTclAddIMethod(in, (XOTcl_Class*) thecls, "mkinstdelegator", (Tcl_ObjCmdProc*)XOTclCInstDelegateCmdMethod, 0, 0); XOTclAddIMethod(in, (XOTcl_Class*) thecls, "parameter", (Tcl_ObjCmdProc*)XOTclCParameterMethod, 0, 0); XOTclAddIMethod(in, (XOTcl_Class*) thecls, "parameterclass", (Tcl_ObjCmdProc*)XOTclCParameterClassMethod, 0, 0); Index: xotcl/library/store/XOTclGdbm/Makefile =================================================================== diff -u -ra095dd118343e4b469b25c6801fd0de73192686c -rd374abc5db9d88ce09ee134350fac67ae0d59e5e --- xotcl/library/store/XOTclGdbm/Makefile (.../Makefile) (revision a095dd118343e4b469b25c6801fd0de73192686c) +++ xotcl/library/store/XOTclGdbm/Makefile (.../Makefile) (revision d374abc5db9d88ce09ee134350fac67ae0d59e5e) @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: Makefile,v 1.6 2004/06/18 08:27:57 neumann Exp $ +# RCS: @(#) $Id: Makefile,v 1.7 2004/06/20 21:14:14 neumann Exp $ #======================================================================== # Add additional lines to handle any additional AC_SUBST cases that Index: xotcl/library/store/XOTclSdbm/Makefile =================================================================== diff -u -ra095dd118343e4b469b25c6801fd0de73192686c -rd374abc5db9d88ce09ee134350fac67ae0d59e5e --- xotcl/library/store/XOTclSdbm/Makefile (.../Makefile) (revision a095dd118343e4b469b25c6801fd0de73192686c) +++ xotcl/library/store/XOTclSdbm/Makefile (.../Makefile) (revision d374abc5db9d88ce09ee134350fac67ae0d59e5e) @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: Makefile,v 1.6 2004/06/18 08:27:57 neumann Exp $ +# RCS: @(#) $Id: Makefile,v 1.7 2004/06/20 21:14:14 neumann Exp $ #======================================================================== # Add additional lines to handle any additional AC_SUBST cases that Index: xotcl/library/xml/TclExpat-1.1/Makefile =================================================================== diff -u -ra095dd118343e4b469b25c6801fd0de73192686c -rd374abc5db9d88ce09ee134350fac67ae0d59e5e --- xotcl/library/xml/TclExpat-1.1/Makefile (.../Makefile) (revision a095dd118343e4b469b25c6801fd0de73192686c) +++ xotcl/library/xml/TclExpat-1.1/Makefile (.../Makefile) (revision d374abc5db9d88ce09ee134350fac67ae0d59e5e) @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: Makefile,v 1.6 2004/06/18 08:27:57 neumann Exp $ +# RCS: @(#) $Id: Makefile,v 1.7 2004/06/20 21:14:14 neumann Exp $ #======================================================================== # Add additional lines to handle any additional AC_SUBST cases that