Index: generic/gentclAPI.decls =================================================================== diff -u -r464811a4aaa475de10e834b0a009521446163fc0 -rcd12f5a50d870605292d8c957cb2a079f1a17c10 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 464811a4aaa475de10e834b0a009521446163fc0) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision cd12f5a50d870605292d8c957cb2a079f1a17c10) @@ -136,7 +136,7 @@ xotclCmd setter XOTclSetterCmd { {-argName "object" -required 1 -type object} {-argName "-per-object"} - {-argName "methodName" -required 1} + {-argName "parameter" -type tclobj} } xotclCmd valuecheck XOTclValuecheckCmd { {-argName "param" -type tclobj} Index: generic/predefined.h =================================================================== diff -u -rc942f4e117d2aa3c8594702e0476a3f73a4147df -rcd12f5a50d870605292d8c957cb2a079f1a17c10 --- generic/predefined.h (.../predefined.h) (revision c942f4e117d2aa3c8594702e0476a3f73a4147df) +++ generic/predefined.h (.../predefined.h) (revision cd12f5a50d870605292d8c957cb2a079f1a17c10) @@ -405,7 +405,7 @@ "\\[list [::xotcl::self] __default_from_cmd \\[::xotcl::self\\] [list [set :initcmd]]\\]\\n\"} elseif [:exists valuecmd] {\n" "append __initcmd \":trace add variable [list ${:name}] read \\\n" "\\[list [::xotcl::self] __value_from_cmd \\[::xotcl::self\\] [list [set :valuecmd]]\\]\"}\n" -"array set \"\" [:toParameterSyntax \"value\"]\n" +"array set \"\" [:toParameterSyntax ${:name}]\n" "if {$(mparam) ne \"\"} {\n" "if {[info exists :multivalued] && ${:multivalued}} {\n" ":method assign [list obj var value:$(mparam),multivalued,slot=[self]] {::xotcl::setinstvar $obj $var $value}\n" Index: generic/predefined.xotcl =================================================================== diff -u -rc942f4e117d2aa3c8594702e0476a3f73a4147df -rcd12f5a50d870605292d8c957cb2a079f1a17c10 --- generic/predefined.xotcl (.../predefined.xotcl) (revision c942f4e117d2aa3c8594702e0476a3f73a4147df) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision cd12f5a50d870605292d8c957cb2a079f1a17c10) @@ -767,7 +767,7 @@ append __initcmd ":trace add variable [list ${:name}] read \ \[list [::xotcl::self] __value_from_cmd \[::xotcl::self\] [list [set :valuecmd]]\]" } - array set "" [:toParameterSyntax "value"] + array set "" [:toParameterSyntax ${:name}] #puts stderr "Attribute.init valueParam for [self] is $(mparam)" if {$(mparam) ne ""} { Index: generic/tclAPI.h =================================================================== diff -u -rc942f4e117d2aa3c8594702e0476a3f73a4147df -rcd12f5a50d870605292d8c957cb2a079f1a17c10 --- generic/tclAPI.h (.../tclAPI.h) (revision c942f4e117d2aa3c8594702e0476a3f73a4147df) +++ generic/tclAPI.h (.../tclAPI.h) (revision cd12f5a50d870605292d8c957cb2a079f1a17c10) @@ -282,7 +282,7 @@ static int XOTclQualifyObjCmd(Tcl_Interp *interp, Tcl_Obj *name); static int XOTclRelationCmd(Tcl_Interp *interp, XOTclObject *object, int relationtype, Tcl_Obj *value); static int XOTclSetInstvarCmd(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *value); -static int XOTclSetterCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, char *methodName); +static int XOTclSetterCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, Tcl_Obj *parameter); static int XOTclValuecheckCmd(Tcl_Interp *interp, Tcl_Obj *param, Tcl_Obj *value); enum { @@ -1928,10 +1928,10 @@ } else { XOTclObject *object = (XOTclObject *)pc.clientData[0]; int withPer_object = (int )PTR2INT(pc.clientData[1]); - char *methodName = (char *)pc.clientData[2]; + Tcl_Obj *parameter = (Tcl_Obj *)pc.clientData[2]; parseContextRelease(&pc); - return XOTclSetterCmd(interp, object, withPer_object, methodName); + return XOTclSetterCmd(interp, object, withPer_object, parameter); } } @@ -2307,7 +2307,7 @@ {"::xotcl::setter", XOTclSetterCmdStub, 3, { {"object", 1, 0, convertToObject}, {"-per-object", 0, 0, convertToString}, - {"methodName", 1, 0, convertToString}} + {"parameter", 0, 0, convertToTclobj}} }, {"::xotcl::valuecheck", XOTclValuecheckCmdStub, 2, { {"param", 0, 0, convertToTclobj}, Index: generic/xotcl.c =================================================================== diff -u -r930db9f3c2dc7b83ba64cbb1c600242ed650adab -rcd12f5a50d870605292d8c957cb2a079f1a17c10 --- generic/xotcl.c (.../xotcl.c) (revision 930db9f3c2dc7b83ba64cbb1c600242ed650adab) +++ generic/xotcl.c (.../xotcl.c) (revision cd12f5a50d870605292d8c957cb2a079f1a17c10) @@ -110,6 +110,8 @@ static int ListMethodName(Tcl_Interp *interp, XOTclObject *object, int withPer_object, CONST char *methodName); +static int ArgumentCheck(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, int *flags, + ClientData *clientData, Tcl_Obj **outObjPtr); typedef enum { CALLING_LEVEL, ACTIVE_LEVEL } CallStackLevel; @@ -125,13 +127,20 @@ XOTclParamDefs *paramDefs; } XOTclProcContext; -typedef struct tclCmdClientData { - XOTclObject *obj; - Tcl_Obj *cmdName; -} tclCmdClientData; +/* tclCmdClientdata is an incomplete type containing the common field(s) + of ForwardCmdClientData, AliasCmdClientData and SetterCmdClientData + used for filling in at runtime the actual object. */ +typedef struct TclCmdClientData { + XOTclObject *object; +} TclCmdClientData; -typedef struct forwardCmdClientData { - XOTclObject *obj; +typedef struct SetterCmdClientData { + XOTclObject *object; + XOTclParam *paramsPtr; +} SetterCmdClientData; + +typedef struct ForwardCmdClientData { + XOTclObject *object; Tcl_Obj *cmdName; Tcl_ObjCmdProc *objProc; ClientData clientData; @@ -146,10 +155,10 @@ Tcl_Obj *prefix; int nr_subcommands; Tcl_Obj *subcommands; -} forwardCmdClientData; +} ForwardCmdClientData; typedef struct AliasCmdClientData { - XOTclObject *obj; + XOTclObject *object; Tcl_Obj *cmdName; Tcl_ObjCmdProc *objProc; ClientData clientData; @@ -5826,9 +5835,11 @@ methodName, "'", (char *) NULL); } } else if (proc == XOTclForwardMethod || - proc == XOTclObjscopedMethod) { - tclCmdClientData *tcd = (tclCmdClientData *)cp; - tcd->obj = object; + proc == XOTclObjscopedMethod || + proc == XOTclSetterMethod + ) { + TclCmdClientData *tcd = (TclCmdClientData *)cp; + tcd->object = object; assert((CmdIsProc(cmd) == 0)); } else if (cp == (ClientData)XOTCL_CMD_NONLEAF_METHOD) { cp = clientData; @@ -6475,7 +6486,7 @@ /* must be a converter defined via method */ paramPtr->converterName = ParamCheckObj(interp, option, length); INCR_REF_COUNT(paramPtr->converterName); - result = ParamOptionSetConverter(interp, paramPtr, "usertype", convertViaCmd); + result = ParamOptionSetConverter(interp, paramPtr, ObjStr(paramPtr->converterName), convertViaCmd); } } @@ -6867,7 +6878,7 @@ } static void forwardCmdDeleteProc(ClientData clientData) { - forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; + ForwardCmdClientData *tcd = (ForwardCmdClientData *)clientData; if (tcd->cmdName) {DECR_REF_COUNT(tcd->cmdName);} if (tcd->subcommands) {DECR_REF_COUNT(tcd->subcommands);} if (tcd->onerror) {DECR_REF_COUNT(tcd->onerror);} @@ -6881,12 +6892,12 @@ Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, int withObjscope, Tcl_Obj *withOnerror, int withVerbose, Tcl_Obj *target, int objc, Tcl_Obj * CONST objv[], - forwardCmdClientData **tcdp) { - forwardCmdClientData *tcd; + ForwardCmdClientData **tcdp) { + ForwardCmdClientData *tcd; int i, result = 0; - tcd = NEW(forwardCmdClientData); - memset(tcd, 0, sizeof(forwardCmdClientData)); + tcd = NEW(ForwardCmdClientData); + memset(tcd, 0, sizeof(ForwardCmdClientData)); if (withDefault) { Tcl_DString ds, *dsPtr = &ds; @@ -8812,16 +8823,35 @@ static int XOTclSetterMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *object = (XOTclObject*)clientData; - + SetterCmdClientData *cd = (SetterCmdClientData*)clientData; + XOTclObject *object = cd->object; + if (!object) return XOTclObjErrType(interp, objv[0], "object", ObjStr(objv[0])); if (objc > 2) return XOTclObjErrArgCnt(interp, object->cmdName, objv[0], "?value?"); - return setInstVar(interp, object, objv[0], objc == 2 ? objv[1] : NULL); + + if (cd->paramsPtr && objc == 2) { + Tcl_Obj *outObjPtr; + int result, flags; + ClientData checkedData; + result = ArgumentCheck(interp, objv[1], cd->paramsPtr, &flags, &checkedData, &outObjPtr); + + if (result == TCL_OK) { + result = setInstVar(interp, object, objv[0], outObjPtr); + + if (flags & XOTCL_PC_MUST_DECR) { + DECR_REF_COUNT(outObjPtr); + } + } + return result; + + } else { + return setInstVar(interp, object, objv[0], objc == 2 ? objv[1] : NULL); + } } static int forwardArg(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], - Tcl_Obj *forwardArgObj, forwardCmdClientData *tcd, Tcl_Obj **out, + Tcl_Obj *forwardArgObj, ForwardCmdClientData *tcd, Tcl_Obj **out, Tcl_Obj **freeList, int *inputArg, int *mapvalue, int firstPosArg, int *outputincr) { char *forwardArgString = ObjStr(forwardArgObj), *p; @@ -8873,7 +8903,7 @@ c1 = *(forwardArgString+1); if (c == 's' && !strcmp(forwardArgString, "self")) { - *out = tcd->obj->cmdName; + *out = tcd->object->cmdName; } else if (c == 'p' && !strcmp(forwardArgString, "proc")) { char *methodName = ObjStr(objv[0]); /* if we dispatch a method via ".", we do not want to see the @@ -9028,10 +9058,10 @@ static int -callForwarder(forwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { +callForwarder(ForwardCmdClientData *tcd, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { ClientData clientData; int result; - XOTclObject *object = tcd->obj; + XOTclObject *object = tcd->object; XOTcl_FrameDecls; if (tcd->verbose) { @@ -9074,7 +9104,7 @@ static int XOTclForwardMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { - forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; + ForwardCmdClientData *tcd = (ForwardCmdClientData *)clientData; int result, j, inputArg = 1, outputArg = 0; #if defined(TCL85STACK) /* no need to store varFramePtr in call frame for tcl85stack */ @@ -9087,7 +9117,7 @@ */ #endif - if (!tcd || !tcd->obj) return XOTclObjErrType(interp, objv[0], "object", ""); + if (!tcd || !tcd->object) return XOTclObjErrType(interp, objv[0], "object", ""); if (tcd->passthrough) { /* two short cuts for simple cases */ /* early binding, cmd *resolved, we have to care only for objscope */ @@ -9275,7 +9305,7 @@ static int XOTclObjscopedMethod(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { AliasCmdClientData *tcd = (AliasCmdClientData *)clientData; - XOTclObject *object = tcd->obj; + XOTclObject *object = tcd->object; int result; XOTcl_FrameDecls; /*fprintf(stderr, "objscopedMethod obj=%p %s, ptr=%p\n", object, objectName(object), tcd->objProc);*/ @@ -9292,6 +9322,15 @@ return result; } +static void setterCmdDeleteProc(ClientData clientData) { + SetterCmdClientData *setterClientData = (SetterCmdClientData *)clientData; + + if (setterClientData->paramsPtr) { + ParamsFree(setterClientData->paramsPtr); + } + FREE(SetterCmdClientData, setterClientData); +} + static void aliasCmdDeleteProc(ClientData clientData) { AliasCmdClientData *tcd = (AliasCmdClientData *)clientData; ImportRef *refPtr, *prevPtr = NULL; @@ -10117,7 +10156,7 @@ } static void -AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, forwardCmdClientData *tcd) { +AppendForwardDefinition(Tcl_Interp *interp, Tcl_Obj *listObj, ForwardCmdClientData *tcd) { if (tcd->prefix) { Tcl_ListObjAppendElement(interp, listObj, Tcl_NewStringObj("-methodprefix",-1)); Tcl_ListObjAppendElement(interp, listObj, tcd->prefix); @@ -10252,7 +10291,7 @@ XOTclAssertionStore *assertions; resultObj = Tcl_NewListObj(0, NULL); - /* todo: don't hard-code registering command name "method" */ + /* todo: don't hard-code registering command name "method" / XOTE_METHOD */ AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_METHOD], object, methodName, cmd, 0, outputPerObject); ListCmdParams(interp, cmd, methodName, 0); @@ -10292,7 +10331,7 @@ if (clientData) { resultObj = Tcl_NewListObj(0, NULL); - /* todo: don't hard-code registering command name "forward" */ + /* todo: don't hard-code registering command name "forward" / XOTE_FORWARD*/ AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_FORWARD], object, methodName, cmd, 0, outputPerObject); AppendForwardDefinition(interp, resultObj, clientData); @@ -10310,7 +10349,7 @@ break; case InfomethodsubcmdDefinitionIdx: resultObj = Tcl_NewListObj(0, NULL); - /* todo: don't hard-code registering command name "setter" */ + /* todo: don't hard-code registering command name "setter" / XOTE_SETTER */ AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_SETTER], object, methodName, cmd, 0, outputPerObject); Tcl_SetObjResult(interp, resultObj); @@ -10332,7 +10371,7 @@ Tcl_Obj **listElements; resultObj = Tcl_NewListObj(0, NULL); Tcl_ListObjGetElements(interp, entryObj, &nrElements, &listElements); - /* todo: don't hard-code registering command name "alias" */ + /* todo: don't hard-code registering command name "alias" / XOTE_ALIAS */ AppendMethodRegistration(interp, resultObj, XOTclGlobalStrings[XOTE_ALIAS], object, methodName, cmd, nrElements!=1, outputPerObject); Tcl_ListObjAppendElement(interp, resultObj, listElements[nrElements-1]); @@ -10505,8 +10544,8 @@ "-definition" */ if (hPtr) { Tcl_Command cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); - ClientData clientData = cmd? Tcl_Command_objClientData(cmd) : NULL; - forwardCmdClientData *tcd = (forwardCmdClientData *)clientData; + ClientData clientData = cmd ? Tcl_Command_objClientData(cmd) : NULL; + ForwardCmdClientData *tcd = (ForwardCmdClientData *)clientData; if (tcd && Tcl_Command_objProc(cmd) == XOTclForwardMethod) { Tcl_Obj *listObj = Tcl_NewListObj(0, NULL); AppendForwardDefinition(interp, listObj, tcd); @@ -10778,7 +10817,7 @@ tcd = NEW(AliasCmdClientData); tcd->cmdName = object->cmdName; tcd->interp = interp; /* just for deleting the associated variable */ - tcd->obj = object; + tcd->object = object; tcd->class = cl ? (XOTclClass *) object : NULL; tcd->objProc = objProc; tcd->aliasedCmd = cmd; @@ -11243,7 +11282,7 @@ Tcl_Obj *withDefault, int withEarlybinding, Tcl_Obj *withMethodprefix, int withObjscope, Tcl_Obj *withOnerror, int withVerbose, Tcl_Obj *target, int nobjc, Tcl_Obj *CONST nobjv[]) { - forwardCmdClientData *tcd = NULL; + ForwardCmdClientData *tcd = NULL; int result; result = forwardProcessOptions(interp, method, @@ -11256,7 +11295,7 @@ (withPer_object || ! XOTclObjectIsClass(object)) ? NULL : (XOTclClass *)object; - tcd->obj = object; + tcd->object = object; if (cl == NULL) { result = XOTclAddObjectMethod(interp, (XOTcl_Object *)object, methodName, (Tcl_ObjCmdProc*)XOTclForwardMethod, @@ -12289,19 +12328,46 @@ xotclCmd setter XOTclSetterCmd { {-argName "object" -required 1 -type object} {-argName "-per-object"} - {-argName "methodName" -required 1} - } */ -static int XOTclSetterCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, - char *methodName) { - int result; + {-argName "parameter" -type tclobj} + } +*/ +static int XOTclSetterCmd(Tcl_Interp *interp, XOTclObject *object, int withPer_object, Tcl_Obj *parameter) { XOTclClass *cl = (withPer_object || ! XOTclObjectIsClass(object)) ? NULL : (XOTclClass *)object; + char *methodName = ObjStr(parameter); + SetterCmdClientData *setterClientData = NEW(SetterCmdClientData); + int j, length, result; + length = strlen(methodName); + + for (j=0; jparamsPtr = ParamsNew(1); + result = ParamParse(interp, "setter", parameter, + XOTCL_DISALLOWED_ARG_METHOD_PARAMETER /* disallowed options */, + setterClientData->paramsPtr, &possibleUnknowns, &plainParams); + + if (result != TCL_OK) { + ParamsFree(setterClientData->paramsPtr); + FREE(SetterCmdClientData, setterClientData); + return result; + } + methodName = setterClientData->paramsPtr->name; + } else { + setterClientData->paramsPtr = NULL; + } + if (cl) { result = XOTclAddClassMethod(interp, (XOTcl_Class *)cl, methodName, - (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); + (Tcl_ObjCmdProc*)XOTclSetterMethod, (ClientData)setterClientData, setterCmdDeleteProc, 0); } else { result = XOTclAddObjectMethod(interp, (XOTcl_Object *)object, methodName, - (Tcl_ObjCmdProc*)XOTclSetterMethod, 0, 0, 0); + (Tcl_ObjCmdProc*)XOTclSetterMethod, (ClientData)setterClientData, setterCmdDeleteProc, 0); } if (result == TCL_OK) { result = ListMethodName(interp, object, withPer_object, methodName); Index: tests/parameters.xotcl =================================================================== diff -u -re5cee71c4fdd11860c1a897522c6d4202ebc64c4 -rcd12f5a50d870605292d8c957cb2a079f1a17c10 --- tests/parameters.xotcl (.../parameters.xotcl) (revision e5cee71c4fdd11860c1a897522c6d4202ebc64c4) +++ tests/parameters.xotcl (.../parameters.xotcl) (revision cd12f5a50d870605292d8c957cb2a079f1a17c10) @@ -138,6 +138,7 @@ ? {C eval {:objectparameter}} \ "-object-mixin:relation,slot=::xotcl2::Class::slot::object-mixin -mixin:relation,arg=class-mixin,slot=::xotcl2::Class::slot::mixin -superclass:relation,slot=::xotcl2::Class::slot::superclass -object-filter:relation,slot=::xotcl2::Class::slot::object-filter -filter:relation,arg=filter-mixin,slot=::xotcl2::Class::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -parameter:method,optional -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" + ? {c1 eval {:objectparameter}} \ "-a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::xotcl2::Object::slot::mixin -filter:relation,slot=::xotcl2::Object::slot::filter -class:relation,slot=::xotcl2::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg arg:initcmd,optional" @@ -497,7 +498,7 @@ # define type twice ? {D method foo {a:int,range,arg=1-3} {return a=$a}} \ - "Refuse to redefine parameter converter to use usertype" \ + "Refuse to redefine parameter converter to use type=range" \ "invalid value" # @@ -776,6 +777,25 @@ ? {p1 foo male} m ? {p1 sex male} m +####################################################### +# test for setters with parameters +####################################################### +Test case setters + +Object create o + +? {::xotcl::setter o a} "::xotcl::classes::o::a" +? {o a 1} "1" + +? {::xotcl::setter o a:integer} "::xotcl::classes::o::a" +? {::xotcl::setter o ints:integer,multivalued} "::xotcl::classes::o::ints" +? {::xotcl::setter o o:object} "::xotcl::classes::o::o" + +? {o a 2} 2 +? {o a hugo} {expected integer but got "hugo" for parameter a} +? {o ints {10 100 1000}} {10 100 1000} +? {o ints hugo} {invalid value in "hugo": expected integer but got "hugo" for parameter ints} +? {o o o} o ## TODO regression test for type checking, parameter options (initcmd, ## substdefault, combinations with defaults, ...), etc. puts stderr =====END