Index: xotcl/ChangeLog =================================================================== diff -u -r772ce5d27ccbfe6d13f4154ebc5db163b410b418 -r19c883b19ed0b21c426ffadf8de717f325b1eeda --- xotcl/ChangeLog (.../ChangeLog) (revision 772ce5d27ccbfe6d13f4154ebc5db163b410b418) +++ xotcl/ChangeLog (.../ChangeLog) (revision 19c883b19ed0b21c426ffadf8de717f325b1eeda) @@ -1,16 +1,18 @@ 2004-06-20 Gustaf.Neumann@wu-wien.ac.at * removed inclusion of - * second version of mkinstdelegator and mkdelegator + * second version of delegatore methods cmd and instcmd A delegator method is defined via - Class instdelegator method COMMAND ARGS + Class instcmd 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... + COMMAND ARGS arg1 INSERTTOKENS arg2 arg3... - Class mkinstdelegator \ + Class instcmd \ ?-nocaller? \ + ?-nomethod? \ + ?-inscope? \ ?-skip nr_of_tokens? \ ?-insert tokens? ?-prefix string? \ @@ -20,7 +22,9 @@ methodname: name of an instcommand for the class to be registered, commandname: command that recieves delegation + -nomethod: don't insert the callers method -nocaller: don't insert caller after method + -inscope: evalute method in obj scope -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 Index: xotcl/doc/langRef-xotcl.html =================================================================== diff -u -r772ce5d27ccbfe6d13f4154ebc5db163b410b418 -r19c883b19ed0b21c426ffadf8de717f325b1eeda --- xotcl/doc/langRef-xotcl.html (.../langRef-xotcl.html) (revision 772ce5d27ccbfe6d13f4154ebc5db163b410b418) +++ xotcl/doc/langRef-xotcl.html (.../langRef-xotcl.html) (revision 19c883b19ed0b21c426ffadf8de717f325b1eeda) @@ -121,7 +121,7 @@ Date: - $Date: 2004/06/20 21:29:09 $ + $Date: 2004/06/20 22:54:13 $ Index: xotcl/generic/xotcl.c =================================================================== diff -u -r772ce5d27ccbfe6d13f4154ebc5db163b410b418 -r19c883b19ed0b21c426ffadf8de717f325b1eeda --- xotcl/generic/xotcl.c (.../xotcl.c) (revision 772ce5d27ccbfe6d13f4154ebc5db163b410b418) +++ xotcl/generic/xotcl.c (.../xotcl.c) (revision 19c883b19ed0b21c426ffadf8de717f325b1eeda) @@ -1,5 +1,5 @@ #define NAMESPACEINSTPROCS 1 -/* $Id: xotcl.c,v 1.5 2004/06/20 21:29:09 neumann Exp $ +/* $Id: xotcl.c,v 1.6 2004/06/20 22:54:13 neumann Exp $ * * XOTcl - Extended OTcl * @@ -116,6 +116,8 @@ Tcl_Obj *args; int skip; int insertcaller; + int insertmethod; + int inscope; Tcl_Obj *prefix; int nr_subcommands; Tcl_Obj *subcommands; @@ -6944,7 +6946,7 @@ static int XOTclDelegateMethod(ClientData cd, Tcl_Interp *in, int objc, Tcl_Obj * CONST objv[]) { delegateCmdClientData *tcd = (delegateCmdClientData *)cd; - /*XOTcl_FrameDecls;*/ + XOTcl_FrameDecls; int result, nrargs, j, inputarg, outputarg=0, clientargs=0; if (!tcd || !tcd->obj) return XOTclObjErrType(in, objv[0], "Object"); @@ -6964,7 +6966,7 @@ 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", + fprintf(stderr,"command %s (%p) nrargs=%d, skip=%d, subcommand=%d, nr_inserts=%d args=%p\n", ObjStr(objv[0]), tcd, nrargs, tcd->skip, tcd->nr_subcommands, @@ -6986,7 +6988,6 @@ ov[outputarg++] = listElements[j]; } } - /* fprintf(stderr, "nrargs=%d, objc=%d, tcd->nr_subcommands=%d size=%d\n", nrargs, objc, tcd->nr_subcommands, @@ -7002,15 +7003,16 @@ 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->insertmethod) { + /* 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]; + } + 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", @@ -7023,8 +7025,8 @@ outputarg ++; } if (objc-inputarg>0) { - /* fprintf(stderr, " copying remaining %d args starting at [%d]\n", - objc-inputarg, outputarg); */ + /*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);*/ @@ -7046,14 +7048,23 @@ } #endif + + if (tcd->inscope) { + XOTcl_PushFrame(in, tcd->obj); + } + if (GetXOTclObjectFromObj(in, tcd->cmdName, (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); + result = Tcl_EvalObjv(in, objc, ov, 0); } + if (tcd->inscope) { + XOTcl_PopFrame(in, tcd->obj); + } + if (tcd->prefix) { DECR_REF_COUNT(ov[1]); } @@ -8475,7 +8486,9 @@ tcd->nr_inserts = 0; tcd->inserts = 0; tcd->prefix = 0; + tcd->inscope = 0; tcd->insertcaller = 1; + tcd->insertmethod = 1; tcd->skip = -1; /* not specified */ for (i=2; iinsertcaller = 0; + } else if (!strcmp(ObjStr(objv[i]),"-nomethod")) { + tcd->insertmethod = 0; + } else if (!strcmp(ObjStr(objv[i]),"-inscope")) { + tcd->inscope = 1; } else { if (tcd->cmdName == 0) { tcd->cmdName = objv[2]; @@ -8553,7 +8570,7 @@ } else { delegate_argc_error: return XOTclObjErrArgCnt(in, cl->object.cmdName, - "mkinstdelegator method obj ?args? ?-defaultmethod name? ?-insert tokens? ?-prefix string? ?-skip #? ?-nocaller?"); + "instcommand method obj ?args? ?-defaultmethod name? ?-insert tokens? ?-prefix string? ?-skip #? ?-nocaller?"); } } @@ -8578,7 +8595,7 @@ } else { delegate_argc_error: return XOTclObjErrArgCnt(in, obj->cmdName, - "mkdelegator method obj ?args? ?-defaultmethod name? ?-insert tokens? ?-prefix string? ?-skip #? ?-nocaller?"); + "command method obj ?args? ?-defaultmethod name? ?-insert tokens? ?-prefix string? ?-skip #? ?-nocaller?"); } } @@ -9757,7 +9774,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, "cmd", (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); @@ -9787,7 +9804,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, "mkinstdelegator", (Tcl_ObjCmdProc*)XOTclCInstDelegateCmdMethod, 0, 0); + XOTclAddIMethod(in, (XOTcl_Class*) thecls, "instcmd", (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/tests/testx.xotcl =================================================================== diff -u -r772ce5d27ccbfe6d13f4154ebc5db163b410b418 -r19c883b19ed0b21c426ffadf8de717f325b1eeda --- xotcl/tests/testx.xotcl (.../testx.xotcl) (revision 772ce5d27ccbfe6d13f4154ebc5db163b410b418) +++ xotcl/tests/testx.xotcl (.../testx.xotcl) (revision 19c883b19ed0b21c426ffadf8de717f325b1eeda) @@ -1,4 +1,4 @@ -#$Id: testx.xotcl,v 1.5 2004/06/20 21:29:09 neumann Exp $ +#$Id: testx.xotcl,v 1.6 2004/06/20 22:54:13 neumann Exp $ package require XOTcl namespace import -force xotcl::* @@ -2856,11 +2856,11 @@ ::errorCheck [b info procs] "objproc" "[self]: info procs" ::errorCheck [B info instprocs] "myProc2" "[self]: info instprocs" - ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure copy defaultmethod destroy eval exists extractConfigureArg f filter filterappend filterguard filtersearch hasclass incr info infoTraceFilter init instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinappend mixinguard mkdelegator move myProc myProc2 myProcMix1 myProcMix2 noinit objproc parametercmd proc procsearch recreate requireNamespace self set setFilter tclcmd trace unset uplevel upvar volatile vwait" "[self]: b info methods" + ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup cmd configure copy defaultmethod destroy eval exists extractConfigureArg f filter filterappend filterguard filtersearch hasclass incr info infoTraceFilter init instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinappend mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objproc parametercmd proc procsearch recreate requireNamespace self set setFilter tclcmd trace unset uplevel upvar volatile vwait" "[self]: b info methods" ::errorCheck [lsort [b info methods -nocmds]] "abstract copy defaultmethod extractConfigureArg f filterappend hasclass infoTraceFilter init mixinappend move myProc myProc2 myProcMix1 myProcMix2 objproc recreate self setFilter" "[self]: b info methods -nocmds" - ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup configure destroy eval exists filter filterguard filtersearch incr info instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinguard mkdelegator noinit parametercmd proc procsearch requireNamespace set tclcmd trace unset uplevel upvar volatile vwait" "[self]: b info methods -noprocs" + ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup cmd configure destroy eval exists filter filterguard filtersearch incr info instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinguard noinit parametercmd proc procsearch requireNamespace set tclcmd trace unset uplevel upvar volatile vwait" "[self]: b info methods -noprocs" ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract copy defaultmethod extractConfigureArg f filterappend hasclass infoTraceFilter init mixinappend move myProc myProc2 objproc self setFilter" "[self]: b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "[self]: b info methods -nocmds -noprocs" @@ -3106,9 +3106,9 @@ set ::context payrollApp - ::errorCheck [lsort [jim info methods]] "__next abstract age append array autoname check class cleanup configure copy defaultmethod destroy driving-license eval exists extractConfigureArg f filter filterappend filterguard filtersearch hasclass id incr info infoTraceFilter init instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinappend mixinguard mkdelegator move name noinit parametercmd print proc procsearch recreate requireNamespace salary self set setFilter signature tclcmd trace unset uplevel upvar volatile vwait" "condmixin all methods" + ::errorCheck [lsort [jim info methods]] "__next abstract age append array autoname check class cleanup cmd configure copy defaultmethod destroy driving-license eval exists extractConfigureArg f filter filterappend filterguard filtersearch hasclass id incr info infoTraceFilter init instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinappend mixinguard move name noinit parametercmd print proc procsearch recreate requireNamespace salary self set setFilter signature tclcmd trace unset uplevel upvar volatile vwait" "condmixin all methods" - ::errorCheck "[lsort [jim info methods -incontext]]" "__next abstract age append array autoname check class cleanup configure copy defaultmethod destroy eval exists extractConfigureArg f filter filterappend filterguard filtersearch hasclass id incr info infoTraceFilter init instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinappend mixinguard mkdelegator move name noinit parametercmd print proc procsearch recreate requireNamespace salary self set setFilter signature tclcmd trace unset uplevel upvar volatile vwait" "all methods in context" + ::errorCheck "[lsort [jim info methods -incontext]]" "__next abstract age append array autoname check class cleanup cmd configure copy defaultmethod destroy eval exists extractConfigureArg f filter filterappend filterguard filtersearch hasclass id incr info infoTraceFilter init instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinappend mixinguard move name noinit parametercmd print proc procsearch recreate requireNamespace salary self set setFilter signature tclcmd trace unset uplevel upvar volatile vwait" "all methods in context" ::errorCheck [my show payrollApp jim] "{payrollApp: jim info methods salary => salary} {payrollApp: jim info methods -incontext salary => salary} {payrollApp: jim info methods driv* => driving-license} {payrollApp: jim info methods -incontext driv* => }" "payrollApp jim" ::errorCheck [my show shipmentApp jim] "{shipmentApp: jim info methods salary => salary} {shipmentApp: jim info methods -incontext salary => } {shipmentApp: jim info methods driv* => driving-license} {shipmentApp: jim info methods -incontext driv* => driving-license}" "shipmentApp jim"