Index: Makefile.in =================================================================== diff -u -rf3cb5afe6aa1b6761b4a9909058f64ff7d64ab92 -r8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02 --- Makefile.in (.../Makefile.in) (revision f3cb5afe6aa1b6761b4a9909058f64ff7d64ab92) +++ Makefile.in (.../Makefile.in) (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) @@ -389,6 +389,7 @@ $(TCLSH) $(src_test_dir_native)/varresolutiontest.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/info-method.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/parameters.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/returns.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/interceptor-slot.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/aliastest.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/protected.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) Index: TODO =================================================================== diff -u -r9d9ae3c8df6dacbb526362d371ad9b8fa2523673 -r8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02 --- TODO (.../TODO) (revision 9d9ae3c8df6dacbb526362d371ad9b8fa2523673) +++ TODO (.../TODO) (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) @@ -1028,6 +1028,12 @@ - extended regression test to avoid CallDirectly on dealloc (the last place, where XOTCL_CMD_NOT_FOUND was used) +- implemented return value checker (for scripted and c-implemented methods) +- additional methodproperty returns (for registering a return value checker) +- support for incrementally adding stuff to paramDefs (such as slotobj or return value) +- new c-function ParamDefsNew() +- added regression test for return value checker + TODO: - nameing * self/current: Index: generic/gentclAPI.decls =================================================================== diff -u -rf3cb5afe6aa1b6761b4a9909058f64ff7d64ab92 -r8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision f3cb5afe6aa1b6761b4a9909058f64ff7d64ab92) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) @@ -181,7 +181,7 @@ {-argName "object" -required 1 -type object} {-argName "-per-object"} {-argName "methodName" -required 1 -type tclobj} - {-argName "methodproperty" -required 1 -type "protected|redefine-protected|slotobj"} + {-argName "methodproperty" -required 1 -type "protected|redefine-protected|returns|slotobj"} {-argName "value" -type tclobj} } xotclCmd my XOTclMyCmd { Index: generic/tclAPI.h =================================================================== diff -u -rf3cb5afe6aa1b6761b4a9909058f64ff7d64ab92 -r8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02 --- generic/tclAPI.h (.../tclAPI.h) (revision f3cb5afe6aa1b6761b4a9909058f64ff7d64ab92) +++ generic/tclAPI.h (.../tclAPI.h) (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) @@ -79,13 +79,13 @@ static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { int index, result; - static CONST char *opts[] = {"protected", "redefine-protected", "slotobj", NULL}; + static CONST char *opts[] = {"protected", "redefine-protected", "returns", "slotobj", NULL}; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "methodproperty", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); *outObjPtr = objPtr; return result; } -enum MethodpropertyIdx {MethodpropertyNULL, MethodpropertyProtectedIdx, MethodpropertyRedefine_protectedIdx, MethodpropertySlotobjIdx}; +enum MethodpropertyIdx {MethodpropertyNULL, MethodpropertyProtectedIdx, MethodpropertyRedefine_protectedIdx, MethodpropertyReturnsIdx, MethodpropertySlotobjIdx}; static int convertToObjectkind(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { Index: generic/xotcl.c =================================================================== diff -u -r9d9ae3c8df6dacbb526362d371ad9b8fa2523673 -r8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02 --- generic/xotcl.c (.../xotcl.c) (revision 9d9ae3c8df6dacbb526362d371ad9b8fa2523673) +++ generic/xotcl.c (.../xotcl.c) (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) @@ -216,6 +216,8 @@ CONST char *methodName, int objc, Tcl_Obj *CONST objv[]); static int ArgumentCheck(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, int *flags, ClientData *clientData, Tcl_Obj **outObjPtr); +static int Parametercheck(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *valueObj, + const char *varNamePrefix, XOTclParam **paramPtrPtr); static CONST char* AliasIndex(Tcl_DString *dsPtr, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object); static int AliasAdd(Tcl_Interp *interp, Tcl_Obj *cmdName, CONST char *methodName, int withPer_object, CONST char *cmd); @@ -5305,7 +5307,7 @@ ParamDefsStore(Tcl_Interp *interp, Tcl_Command cmd, XOTclParamDefs *paramDefs) { Command *cmdPtr = (Command *)cmd; - if (cmdPtr->deleteProc == TclProcDeleteProc) { + if (cmdPtr->deleteProc != XOTclProcDeleteProc) { XOTclProcContext *ctxPtr = NEW(XOTclProcContext); /*fprintf(stderr, "paramDefsStore replace deleteProc %p by %p\n", @@ -5317,16 +5319,39 @@ ctxPtr->paramDefs = paramDefs; cmdPtr->deleteData = (ClientData)ctxPtr; return TCL_OK; + } else { + /*fprintf(stderr, "paramDefsStore cmd %p has already XOTclProcDeleteProc deleteData %p\n", + cmd, cmdPtr->deleteData);*/ + if (cmdPtr->deleteData) { + XOTclProcContext *ctxPtr = cmdPtr->deleteData; + assert(ctxPtr->paramDefs == NULL); + ctxPtr->paramDefs = paramDefs; + } } return TCL_ERROR; } +static XOTclParamDefs * +ParamDefsNew() { + XOTclParamDefs *paramDefs; + + paramDefs = NEW(XOTclParamDefs); + memset(paramDefs, 0, sizeof(XOTclParamDefs)); + /*fprintf(stderr, "ParamDefsNew %p\n", paramDefs);*/ + + return paramDefs; +} + + static void ParamDefsFree(XOTclParamDefs *paramDefs) { - /*fprintf(stderr, "ParamDefsFree %p\n", paramDefs);*/ + /*fprintf(stderr, "ParamDefsFree %p returns %p\n", paramDefs, paramDefs->returns);*/ + if (paramDefs->paramsPtr) { ParamsFree(paramDefs->paramsPtr); } + if (paramDefs->slotobj) {DECR_REF_COUNT(paramDefs->slotobj);} + if (paramDefs->returns) {DECR_REF_COUNT(paramDefs->returns);} FREE(XOTclParamDefs, paramDefs); } @@ -5481,6 +5506,16 @@ ); # endif + { XOTclParamDefs *paramDefs = ParamDefsGet(cscPtr->cmdPtr); + + if (result == TCL_OK && paramDefs && paramDefs->returns) { + Tcl_Obj *valueObj = Tcl_GetObjResult(interp); + /*fprintf(stderr, "***** we have returns for method '%s' check %s, value %p\n", + methodName, ObjStr(paramDefs->returns), valueObj);*/ + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", NULL); + } + } + if (opt && object->teardown && (opt->checkoptions & CHECK_POST)) { /* even, when the passed result != TCL_OK, run assertion to report * the highest possible method from the callstack (e.g. "set" would not @@ -5517,6 +5552,7 @@ XOTclCallStackContent *cscPtr) { int result, releasePc = 0; XOTclObjectOpt *opt = object->opt; + XOTclParamDefs *paramDefs; #if defined(NRE) parseContext *pcPtr = NULL; #else @@ -5595,31 +5631,31 @@ #endif /* - If the method to be invoked hasparamDefs, we have to call the + If the method to be invoked has paramDefs, we have to call the argument parser with the argument definitions obtained from the proc context from the cmdPtr. */ - { - XOTclParamDefs *paramDefs = Tcl_Command_deleteProc(cmdPtr) == XOTclProcDeleteProc ? - ((XOTclProcContext *)Tcl_Command_deleteData(cmdPtr))->paramDefs : NULL; + paramDefs = ParamDefsGet(cmdPtr); - if (paramDefs) { + /*Tcl_Command_deleteProc(cmdPtr) == XOTclProcDeleteProc ? + ((XOTclProcContext *)Tcl_Command_deleteData(cmdPtr))->paramDefs : NULL;*/ + + if (paramDefs && paramDefs->paramsPtr) { #if defined(NRE) - pcPtr = (parseContext *) TclStackAlloc(interp, sizeof(parseContext)); + pcPtr = (parseContext *) TclStackAlloc(interp, sizeof(parseContext)); # if defined(TCL_STACK_ALLOC_TRACE) - fprintf(stderr, "---- parseContext alloc %p\n", pcPtr); + fprintf(stderr, "---- parseContext alloc %p\n", pcPtr); # endif #endif - result = ProcessMethodArguments(pcPtr, interp, object, 1, paramDefs, methodName, objc, objv); - cscPtr->objc = objc; - cscPtr->objv = (Tcl_Obj **)objv; - if (result == TCL_OK) { - releasePc = 1; - result = PushProcCallFrame(cp, interp, pcPtr->objc, pcPtr->full_objv, cscPtr); - } - } else { - result = PushProcCallFrame(cp, interp, objc, objv, cscPtr); + result = ProcessMethodArguments(pcPtr, interp, object, 1, paramDefs, methodName, objc, objv); + cscPtr->objc = objc; + cscPtr->objv = (Tcl_Obj **)objv; + if (result == TCL_OK) { + releasePc = 1; + result = PushProcCallFrame(cp, interp, pcPtr->objc, pcPtr->full_objv, cscPtr); } + } else { + result = PushProcCallFrame(cp, interp, objc, objv, cscPtr); } /* we could consider to run here ARG_METHOD or ARG_INITCMD @@ -5676,6 +5712,13 @@ Tcl_Interp_returnCode(interp), result);*/ # endif + if (result == TCL_OK && paramDefs && paramDefs->returns) { + Tcl_Obj *valueObj = Tcl_GetObjResult(interp); + /*fprintf(stderr, "***** we have returns for method '%s' check %s, value %p is shared %d\n", + methodName, ObjStr(paramDefs->returns), valueObj, Tcl_IsShared(valueObj));*/ + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", NULL); + } + opt = object->opt; if (opt && object->teardown && (opt->checkoptions & CHECK_POST)) { @@ -5754,6 +5797,16 @@ } } + { XOTclParamDefs *paramDefs = ParamDefsGet(cmdPtr); + + if (result == TCL_OK && paramDefs && paramDefs->returns) { + Tcl_Obj *valueObj = Tcl_GetObjResult(interp); + /* fprintf(stderr, "***** CMD we have returns for method '%s' check %s, value %p\n", + methodName, ObjStr(paramDefs->returns), valueObj);*/ + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", NULL); + } + } + finish: return result; } @@ -6751,10 +6804,7 @@ lastParamPtr->flags &= ~XOTCL_ARG_REQUIRED; } - paramDefs = NEW(XOTclParamDefs); - MEM_COUNT_ALLOC("paramDefs", paramDefs); - - paramDefs->slotObj = NULL; + paramDefs = ParamDefsNew(); paramDefs->paramsPtr = paramsPtr; paramDefs->nrParams = paramPtr-paramsPtr; /*fprintf(stderr, "method %s ifsize %d, possible unknowns = %d,\n", @@ -9444,6 +9494,7 @@ int objc, i, result; Tcl_Obj **ov; + /*fprintf(stderr, "ArgumentCheckHelper\n");*/ assert(pPtr->flags & XOTCL_ARG_MULTIVALUED); result = Tcl_ListObjGetElements(interp, objPtr, &objc, &ov); @@ -9464,6 +9515,9 @@ result = (*pPtr->converter)(interp, ov[i], pPtr, clientData, &elementObjPtr); } + /*fprintf(stderr, "ArgumentCheckHelper convert %s result %d (%s)\n", + valueString, result, ObjStr(elementObjPtr));*/ + if (result == TCL_OK) { Tcl_ListObjAppendElement(interp, *outObjPtr, elementObjPtr); } else { @@ -9523,8 +9577,8 @@ switch to the version of this handler building an output list */ - /*fprintf(stderr, "switch to output list construction for value %s\n", - ObjStr(elementObjPtr));*/ + fprintf(stderr, "switch to output list construction for value %s\n", + ObjStr(elementObjPtr)); *flags |= XOTCL_PC_MUST_DECR; result = ArgumentCheckHelper(interp, objPtr, pPtr, flags, clientData, outObjPtr); break; @@ -11362,7 +11416,7 @@ {-argName "object" -required 1 -type object} {-argName "-per-object"} {-argName "methodName" -required 1 -type tclobj} - {-argName "methodproperty" -required 1 -type "protected|redefine-protected|slotobj"} + {-argName "methodproperty" -required 1 -type "protected|redefine-protected|returns|slotobj"} {-argName "value" -type tclobj} } */ @@ -11371,6 +11425,9 @@ CONST char *methodName = ObjStr(methodObj); Tcl_Command cmd = NULL; + /*fprintf(stderr, "methodProperty for method '%s' prop %d value %s\n", + methodName, methodproperty, valueObj ? ObjStr(valueObj) : "NULL");*/ + if (*methodName == ':') { cmd = Tcl_GetCommandFromObj(interp, methodObj); if (!cmd) { @@ -11405,47 +11462,69 @@ } } - if (methodproperty == MethodpropertyProtectedIdx - || methodproperty == MethodpropertyRedefine_protectedIdx) { + switch (methodproperty) { + case MethodpropertyProtectedIdx: /* fall through */ + case MethodpropertyRedefine_protectedIdx: + { + int flag = methodproperty == MethodpropertyProtectedIdx ? + XOTCL_CMD_PROTECTED_METHOD : + XOTCL_CMD_REDEFINE_PROTECTED_METHOD; + + if (valueObj) { + int bool, result; + result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); + if (result != TCL_OK) { + return result; + } + if (bool) { + Tcl_Command_flags(cmd) |= flag; + } else { + Tcl_Command_flags(cmd) &= ~flag; + } + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), (Tcl_Command_flags(cmd) & flag) != 0); + break; + } + case MethodpropertySlotobjIdx: + case MethodpropertyReturnsIdx: + { + XOTclParamDefs *paramDefs; + Tcl_Obj **objPtr; - int flag = methodproperty == MethodpropertyProtectedIdx ? - XOTCL_CMD_PROTECTED_METHOD : - XOTCL_CMD_REDEFINE_PROTECTED_METHOD; + if (valueObj == NULL && methodproperty == MethodpropertySlotobjIdx) { + return XOTclVarErrMsg(interp, "Option 'slotobj' of method ", methodName, + " requires argument '", (char *) NULL); + } - if (valueObj) { - int bool, result; - result = Tcl_GetBooleanFromObj(interp, valueObj, &bool); - if (result != TCL_OK) { - return result; + paramDefs = ParamDefsGet(cmd); + /*fprintf(stderr, "MethodProperty, ParamDefsGet cmd %p paramDefs %p returns %p\n", + cmd, paramDefs, paramDefs?paramDefs->returns:NULL);*/ + + if (paramDefs == NULL) { + paramDefs = ParamDefsNew(); + ParamDefsStore(interp, cmd, paramDefs); + /*fprintf(stderr, "new param defs %p for cmd %p %s\n", paramDefs, cmd, methodName);*/ } - if (bool) { - Tcl_Command_flags(cmd) |= flag; + objPtr = methodproperty == MethodpropertySlotobjIdx ? ¶mDefs->slotObj : ¶mDefs->returns; + if (valueObj == NULL) { + /* must be a returns query */ + Tcl_SetObjResult(interp, *objPtr ? *objPtr : XOTclGlobalObjs[XOTE_EMPTY]); } else { - Tcl_Command_flags(cmd) &= ~flag; + const char *valueString = ObjStr(valueObj); + /* Set a new value; if there is already a value, free it */ + if (*objPtr) { + DECR_REF_COUNT(*objPtr); + } + if (*valueString == '\0') { + /* set the value to NULL */ + *objPtr = NULL; + } else { + *objPtr = valueObj; + INCR_REF_COUNT(*objPtr); + } } + break; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), (Tcl_Command_flags(cmd) & flag) != 0); - } else { /* slotobj */ - XOTclParamDefs *paramDefs; - - if (valueObj == NULL) { - return XOTclVarErrMsg(interp, "Option 'slotobj' of method ", methodName, - " requires argument '", (char *) NULL); - } - - paramDefs = ParamDefsGet(cmd); - if (paramDefs == NULL) { - paramDefs = NEW(XOTclParamDefs); - memset(paramDefs, 0, sizeof(XOTclParamDefs)); - ParamDefsStore(interp, cmd, paramDefs); - } else { - fprintf(stderr, "define slotobj for a method with nonpospargs\n slotobj = %s \n", ObjStr(valueObj)); - if (paramDefs->slotObj) { - DECR_REF_COUNT(paramDefs->slotObj); - } - } - paramDefs->slotObj = valueObj; - INCR_REF_COUNT(paramDefs->slotObj); } return TCL_OK; @@ -12383,12 +12462,13 @@ } static int -ParamSetFromAny( +ParamSetFromAny2( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + const char *varNamePrefix, /* shows up as varname in error message */ register Tcl_Obj *objPtr) /* The object to convert. */ { XOTclParamWrapper *paramWrapperPtr = NEW(XOTclParamWrapper); - Tcl_Obj *fullParamObj = Tcl_NewStringObj("value:", 6); + Tcl_Obj *fullParamObj = Tcl_NewStringObj(varNamePrefix, -1); int result, possibleUnknowns = 0, plainParams = 0; paramWrapperPtr->paramPtr = ParamsNew(1); @@ -12419,26 +12499,29 @@ return result; } -/* -xotclCmd parametercheck XOTclParametercheckCmd { - {-argName "param" -type tclobj} - {-argName "-nocomplain"} - {-argName "value" -required 0 -type tclobj} - } -*/ -static int XOTclParametercheckCmd(Tcl_Interp *interp, int withNocomplain, Tcl_Obj *objPtr, Tcl_Obj *valueObj) { +static int +ParamSetFromAny( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr) /* The object to convert. */ +{ + return ParamSetFromAny2(interp, "value:", objPtr); +} + +static int Parametercheck(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *valueObj, + const char *varNamePrefix, XOTclParam **paramPtrPtr) { XOTclParamWrapper *paramWrapperPtr; + Tcl_Obj *outObjPtr = NULL; XOTclParam *paramPtr; ClientData checkedData; - Tcl_Obj *outObjPtr; int result, flags = 0; - /*fprintf(stderr, "XOTclParametercheckCmd %s %s\n",ObjStr(objPtr), ObjStr(valueObj));*/ + /*fprintf(stderr, "XOTclParametercheckCmd %s value %p %s\n", + ObjStr(objPtr), valueObj, ObjStr(valueObj));*/ if (objPtr->typePtr == ¶mObjType) { paramWrapperPtr = (XOTclParamWrapper *) objPtr->internalRep.twoPtrValue.ptr1; } else { - result = ParamSetFromAny(interp, objPtr); + result = ParamSetFromAny2(interp, varNamePrefix, objPtr); if (result == TCL_OK) { paramWrapperPtr = (XOTclParamWrapper *) objPtr->internalRep.twoPtrValue.ptr1; } else { @@ -12448,35 +12531,55 @@ } } paramPtr = paramWrapperPtr->paramPtr; + if (paramPtrPtr) *paramPtrPtr = paramPtr; result = ArgumentCheck(interp, valueObj, paramPtr, &flags, &checkedData, &outObjPtr); - if (paramPtr->converter == convertViaCmd && - (withNocomplain || result == TCL_OK)) { - /* fprintf(stderr, "reset result %p %p\n", value, outObjPtr);*/ - Tcl_ResetResult(interp); - } + /*fprintf(stderr, "XOTclParametercheckCmd paramPtr %p final refcount of wrapper %d can free %d\n", + paramPtr, paramWrapperPtr->refCount, paramWrapperPtr->canFree);*/ + if (paramWrapperPtr->refCount == 0) { + /* fprintf(stderr, "XOTclParametercheckCmd paramPtr %p manual free\n",paramPtr);*/ + ParamsFree(paramWrapperPtr->paramPtr); + FREE(XOTclParamWrapper, paramWrapperPtr); + } else { + paramWrapperPtr->canFree = 1; + } + if (flags & XOTCL_PC_MUST_DECR) { DECR_REF_COUNT(outObjPtr); } + return result; +} + +/* +xotclCmd parametercheck XOTclParametercheckCmd { + {-argName "param" -type tclobj} + {-argName "-nocomplain"} + {-argName "value" -required 0 -type tclobj} + } +*/ +static int XOTclParametercheckCmd(Tcl_Interp *interp, int withNocomplain, Tcl_Obj *objPtr, Tcl_Obj *valueObj) { + XOTclParam *paramPtr = NULL; + int result; + + result = Parametercheck(interp, objPtr, valueObj, "value:", ¶mPtr); + + /*fprintf(stderr, "after convert\n");*/ + + if (paramPtr && paramPtr->converter == convertViaCmd && + (withNocomplain || result == TCL_OK)) { + fprintf(stderr, "reset result %p\n", valueObj); + Tcl_ResetResult(interp); + } + if (withNocomplain) { Tcl_SetIntObj(Tcl_GetObjResult(interp), (result == TCL_OK)); result = TCL_OK; } else if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } - /*fprintf(stderr, "XOTclParametercheckCmd paramPtr %p final refcount of wrapper %d can free %d\n",paramPtr, - paramWrapperPtr->refCount, paramWrapperPtr->canFree);*/ - if (paramWrapperPtr->refCount == 0) { - /* fprintf(stderr, "XOTclParametercheckCmd paramPtr %p manual free\n",paramPtr);*/ - ParamsFree(paramWrapperPtr->paramPtr); - FREE(XOTclParamWrapper, paramWrapperPtr); - } else { - paramWrapperPtr->canFree = 1; - } - return result; } Index: generic/xotclInt.h =================================================================== diff -u -r9d9ae3c8df6dacbb526362d371ad9b8fa2523673 -r8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02 --- generic/xotclInt.h (.../xotclInt.h) (revision 9d9ae3c8df6dacbb526362d371ad9b8fa2523673) +++ generic/xotclInt.h (.../xotclInt.h) (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) @@ -431,6 +431,7 @@ XOTclParam *paramsPtr; int nrParams; Tcl_Obj *slotObj; + Tcl_Obj *returns; } XOTclParamDefs; typedef struct XOTclParsedParam { Index: tests/parameters.tcl =================================================================== diff -u -r3cb6a6a8f1e33e63abeec25b3c36231702af6fe2 -r8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02 --- tests/parameters.tcl (.../parameters.tcl) (revision 3cb6a6a8f1e33e63abeec25b3c36231702af6fe2) +++ tests/parameters.tcl (.../parameters.tcl) (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) @@ -872,7 +872,6 @@ # Note that this converter does NOT return a value; it converts all # values into emtpy strings. } - ? {::nsf::parametercheck mType,slot=::tmpObj,multivalued {1 0}} \ {invalid value in "1 0": expected false but got 1} \ "fail on first value" Index: tests/returns.tcl =================================================================== diff -u --- tests/returns.tcl (revision 0) +++ tests/returns.tcl (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) @@ -0,0 +1,118 @@ +package require nx; # namespace import -force ::nx::* +package require nx::test + +Test parameter count 10 +Test case int-returns { + nx::Class create C { + # scripted method without paramdefs + :method bar-ok1 {a b} {return 1} + :method bar-ok2 {a b} {return $a} + # scripted method with paramdefs + :method bar-nok {a b:integer} {return a} + # alias to tcl-cmd (no param defs) + :alias -objscope incr ::incr + :alias -objscope lappend ::lappend + :create c1 + } + + ::nsf::methodproperty C bar-ok1 returns integer + ::nsf::methodproperty C bar-ok2 returns integer + ::nsf::methodproperty C bar-nok returns integer + ::nsf::methodproperty C incr returns integer + ::nsf::methodproperty C lappend returns integer + + ? {c1 bar-ok1 1 2} 1 + ? {c1 bar-ok2 1 2} 1 + ? {c1 bar-nok 1 2} {expected integer but got "a" for parameter return-value} + + ? {c1 incr x} 1 + ? {c1 incr x} 12 + + ? {c1 lappend l e1} {expected integer but got "e1" for parameter return-value} + + # query the returns value + ? {::nsf::methodproperty C lappend returns} integer + + # reset it to emtpy + ? {::nsf::methodproperty C lappend returns ""} "" + + # no checking on lappend + ? {c1 lappend l e2} "e1 e2" + + # query returns "", if there is no returns checking + ? {::nsf::methodproperty C lappend returns} "" + ? {::nsf::methodproperty ::nx::Object method returns} "" + +} + +Test case app-specific-returns { + + ::nx::methodParameterSlot method type=range {name value arg} { + foreach {min max} [split $arg -] break + if {$value < $min || $value > $max} { + error "Value '$value' of parameter $name not between $min and $max" + } + return $value + } + + nx::Class create C { + :method bar-ok1 {a b} {return 1} + :method bar-ok2 {a b} {return $a} + :method bar-nok {a b:integer} {return a} + :alias -objscope incr ::incr + :alias -objscope lappend ::lappend + :create c1 + } + + ::nsf::methodproperty C bar-ok1 returns range,arg=1-3 + ::nsf::methodproperty C bar-ok2 returns range,arg=1-3 + ::nsf::methodproperty C bar-nok returns range,arg=1-3 + ::nsf::methodproperty C incr returns range,arg=1-30 + ::nsf::methodproperty C lappend returns range,arg=1-30 + + ? {c1 bar-ok1 1 2} 1 + ? {c1 bar-ok2 1 2} 1 + ? {c1 bar-nok 1 2} {Value 'a' of parameter return-value not between 1 and 3} + + ? {c1 incr x} 1 + ? {c1 incr x} 12 + + ? {c1 lappend l e1} {Value 'e1' of parameter return-value not between 1 and 30} +} + +Test case converting-returns { + + ::nx::methodParameterSlot method type=sex {name value args} { + #puts stderr "[current] slot specific converter" + switch -glob $value { + m* {return m} + f* {return f} + default {error "expected sex but got $value"} + } + } + + nx::Class create C { + :method bar-ok1 {a b} {return male} + :method bar-ok2 {a b} {return $a} + :method bar-nok {a b:integer} {return $b} + :alias -objscope set ::set + :create c1 + } + + ::nsf::methodproperty C bar-ok1 returns sex + ::nsf::methodproperty C bar-ok2 returns sex + ::nsf::methodproperty C bar-nok returns sex + ::nsf::methodproperty C set returns sex + + ? {c1 bar-ok1 1 2} m + ? {c1 bar-ok2 female 2} f + ? {c1 bar-nok 1 6} {expected sex but got 6} + + ? {c1 set x male} m + ? {c1 eval {set :x}} male + ? {c1 set x} m + + ? {c1 set x hugo} {expected sex but got hugo} +} + +