Index: TODO =================================================================== diff -u -ra3e419eb3993464990b3f32550892e1bc11124fd -r7efafd7b19c58bf0f5ac486779e8ce778e60c9bb --- TODO (.../TODO) (revision a3e419eb3993464990b3f32550892e1bc11124fd) +++ TODO (.../TODO) (revision 7efafd7b19c58bf0f5ac486779e8ce778e60c9bb) @@ -1259,6 +1259,11 @@ (example: "Class create C -parameter {x:integer,nosetter}") - extended regression test to include "nosetter" +- new flag for configure: "nx::configure checkresult on|off" +- turn off result-checking for non-converters, when checking is off + (per default, it is on) +- extended regression test for optional result checking + TODO: - reflect changes in /is/objectproperty/info has/info is/ in migration guide - implement built-in-converter for "baseclass" and "metaclass"? Index: generic/gentclAPI.decls =================================================================== diff -u -r761c9758221eb84b88a328e659523c4773aa5dfe -r7efafd7b19c58bf0f5ac486779e8ce778e60c9bb --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 761c9758221eb84b88a328e659523c4773aa5dfe) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 7efafd7b19c58bf0f5ac486779e8ce778e60c9bb) @@ -32,7 +32,7 @@ } xotclCmd configure XOTclConfigureCmd { - {-argName "configureoption" -required 1 -type "filter|softrecreate|objectsystems|keepinitcmd"} + {-argName "configureoption" -required 1 -type "filter|softrecreate|objectsystems|keepinitcmd|checkresult"} {-argName "value" -required 0 -type tclobj} } xotclCmd createobjectsystem XOTclCreateObjectSystemCmd { Index: generic/tclAPI.h =================================================================== diff -u -r761c9758221eb84b88a328e659523c4773aa5dfe -r7efafd7b19c58bf0f5ac486779e8ce778e60c9bb --- generic/tclAPI.h (.../tclAPI.h) (revision 761c9758221eb84b88a328e659523c4773aa5dfe) +++ generic/tclAPI.h (.../tclAPI.h) (revision 7efafd7b19c58bf0f5ac486779e8ce778e60c9bb) @@ -79,13 +79,13 @@ static int convertToConfigureoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { int index, result; - static CONST char *opts[] = {"filter", "softrecreate", "objectsystems", "keepinitcmd", NULL}; + static CONST char *opts[] = {"filter", "softrecreate", "objectsystems", "keepinitcmd", "checkresult", NULL}; result = Tcl_GetIndexFromObj(interp, objPtr, opts, "configureoption", 0, &index); *clientData = (ClientData) INT2PTR(index + 1); *outObjPtr = objPtr; return result; } -enum ConfigureoptionIdx {ConfigureoptionNULL, ConfigureoptionFilterIdx, ConfigureoptionSoftrecreateIdx, ConfigureoptionObjectsystemsIdx, ConfigureoptionKeepinitcmdIdx}; +enum ConfigureoptionIdx {ConfigureoptionNULL, ConfigureoptionFilterIdx, ConfigureoptionSoftrecreateIdx, ConfigureoptionObjectsystemsIdx, ConfigureoptionKeepinitcmdIdx, ConfigureoptionCheckresultIdx}; static int convertToCurrentoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { Index: generic/xotcl.c =================================================================== diff -u -rb6d81c6521d1e1d58f00763f5ab30a0946cc222a -r7efafd7b19c58bf0f5ac486779e8ce778e60c9bb --- generic/xotcl.c (.../xotcl.c) (revision b6d81c6521d1e1d58f00763f5ab30a0946cc222a) +++ generic/xotcl.c (.../xotcl.c) (revision 7efafd7b19c58bf0f5ac486779e8ce778e60c9bb) @@ -219,7 +219,7 @@ 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); + const char *varNamePrefix, int doCheck, 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); @@ -5538,7 +5538,9 @@ 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); + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", + RUNTIME_STATE(interp)->doCheckresult, + NULL); } } @@ -5742,7 +5744,9 @@ 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); + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", + RUNTIME_STATE(interp)->doCheckresult, + NULL); } opt = object->opt; @@ -5829,7 +5833,9 @@ 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); + result = Parametercheck(interp, paramDefs->returns, valueObj, "return-value:", + RUNTIME_STATE(interp)->doCheckresult, + NULL); } } @@ -6516,7 +6522,23 @@ static int convertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData, Tcl_Obj **outObjPtr) { Tcl_Obj *ov[5]; + Tcl_Obj *savedResult; int result, oc; + + /* + * In general, when the converter is used e.g. for result checking, + * we do not want to alter the result just when the converter sets a + * result. So, for non-converter, we save the old result and restore + * it before the return in case of success. Strictly speaking, + * result-overwritng just harms for result-converters, but saving is + * always semantic correct. + */ + if ((pPtr->flags & XOTCL_ARG_IS_CONVERTER) == 0) { + savedResult = Tcl_GetObjResult(interp); /* save the result */ + INCR_REF_COUNT(savedResult); + } else { + savedResult = NULL; + } ov[0] = pPtr->slotObj ? pPtr->slotObj : XOTclGlobalObjs[XOTE_METHOD_PARAMETER_SLOT_OBJ]; ov[1] = pPtr->converterName; @@ -6530,29 +6552,42 @@ ov[4] = pPtr->converterArg; oc++; } - + + INCR_REF_COUNT(ov[1]); INCR_REF_COUNT(ov[2]); result = Tcl_EvalObjv(interp, oc, ov, 0); DECR_REF_COUNT(ov[1]); DECR_REF_COUNT(ov[2]); + /* per default, the input arg is the output arg */ *outObjPtr = objPtr; - + if (result == TCL_OK) { - /*fprintf(stderr, "convertViaCmd converts %s to '%s' paramPtr %p\n", - ObjStr(objPtr), ObjStr(Tcl_GetObjResult(interp)),pPtr);*/ + /*fprintf(stderr, "convertViaCmd could convert %s to '%s' paramPtr %p, is_converter %d\n", + ObjStr(objPtr), ObjStr(Tcl_GetObjResult(interp)),pPtr, + pPtr->flags & XOTCL_ARG_IS_CONVERTER);*/ if (pPtr->flags & XOTCL_ARG_IS_CONVERTER) { /* * If we want to convert, the resulting obj is the result of the * converter. incr refCount is necessary e.g. for e.g. * return [expr {$value + 1}] */ *outObjPtr = Tcl_GetObjResult(interp); - INCR_REF_COUNT(*outObjPtr); + INCR_REF_COUNT(*outObjPtr); } *clientData = (ClientData) *outObjPtr; - } + + if (savedResult) { + /*fprintf(stderr, "restore savedResult %p\n", savedResult);*/ + Tcl_SetObjResult(interp, savedResult); /* restore the result */ + } + } + + if (savedResult) { + DECR_REF_COUNT(savedResult); + } + return result; } @@ -11069,7 +11104,7 @@ /* xotclCmd configure XOTclConfigureCmd { - {-argName "configureoption" -required 1 -type "filter|softrecreate|objectsystems|keepinitcmd"} + {-argName "configureoption" -required 1 -type "filter|softrecreate|objectsystems|keepinitcmd|checkresult"} {-argName "value" -required 0 -type tclobj} } */ @@ -11117,6 +11152,14 @@ if (valueObj) RUNTIME_STATE(interp)->doKeepinitcmd = bool; break; + + case ConfigureoptionCheckresultIdx: + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), + (RUNTIME_STATE(interp)->doCheckresult)); + if (valueObj) + RUNTIME_STATE(interp)->doCheckresult = bool; + break; + } return TCL_OK; } @@ -11563,7 +11606,7 @@ XOTclParam *paramPtr = NULL; int result; - result = Parametercheck(interp, constraintObj, valueObj, "value:", ¶mPtr); + result = Parametercheck(interp, constraintObj, valueObj, "value:", 1, ¶mPtr); if (paramPtr == NULL) { /* @@ -12673,7 +12716,7 @@ } static int Parametercheck(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *valueObj, - const char *varNamePrefix, XOTclParam **paramPtrPtr) { + const char *varNamePrefix, int doCheck, XOTclParam **paramPtrPtr) { XOTclParamWrapper *paramWrapperPtr; Tcl_Obj *outObjPtr = NULL; XOTclParam *paramPtr; @@ -12697,6 +12740,18 @@ } paramPtr = paramWrapperPtr->paramPtr; if (paramPtrPtr) *paramPtrPtr = paramPtr; + + if (paramPtr->flags & XOTCL_ARG_IS_CONVERTER) { + /* always call checker if it is a converter */ + doCheck = 1; + } + + if (!doCheck) { + outObjPtr = valueObj; + checkedData = ObjStr(valueObj); + return TCL_OK; + } + result = ArgumentCheck(interp, valueObj, paramPtr, &flags, &checkedData, &outObjPtr); /*fprintf(stderr, "ParamSetFromAny paramPtr %p final refcount of wrapper %d can free %d\n", @@ -14992,6 +15047,7 @@ #endif RUNTIME_STATE(interp)->doFilters = 1; + RUNTIME_STATE(interp)->doCheckresult = 1; /* create xotcl namespace */ RUNTIME_STATE(interp)->XOTclNS = Index: generic/xotclInt.h =================================================================== diff -u -rb6d81c6521d1e1d58f00763f5ab30a0946cc222a -r7efafd7b19c58bf0f5ac486779e8ce778e60c9bb --- generic/xotclInt.h (.../xotclInt.h) (revision b6d81c6521d1e1d58f00763f5ab30a0946cc222a) +++ generic/xotclInt.h (.../xotclInt.h) (revision 7efafd7b19c58bf0f5ac486779e8ce778e60c9bb) @@ -380,7 +380,7 @@ #define XOTCL_DISALLOWED_ARG_METHOD_PARAMETER (XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION) #define XOTCL_DISALLOWED_ARG_SETTER (XOTCL_ARG_SUBST_DEFAULT|XOTCL_DISALLOWED_ARG_METHOD_PARAMETER) #define XOTCL_DISALLOWED_ARG_OBJECT_PARAMETER 0 -#define XOTCL_DISALLOWED_ARG_VALUEECHECK (XOTCL_ARG_SUBST_DEFAULT|XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION|XOTCL_ARG_SWITCH|XOTCL_ARG_CURRENTLY_UNKNOWN|XOTCL_ARG_IS_CONVERTER) +#define XOTCL_DISALLOWED_ARG_VALUEECHECK (XOTCL_ARG_SUBST_DEFAULT|XOTCL_ARG_METHOD|XOTCL_ARG_INITCMD|XOTCL_ARG_RELATION|XOTCL_ARG_SWITCH|XOTCL_ARG_CURRENTLY_UNKNOWN) /* method types */ @@ -664,6 +664,8 @@ int doFilters; int doSoftrecreate; int doKeepinitcmd; + int doCheckresult; + int doCheckparameter; int exitHandlerDestroyRound; int returnCode; int overloadedMethods; Index: tests/parameters.tcl =================================================================== diff -u -ra3e419eb3993464990b3f32550892e1bc11124fd -r7efafd7b19c58bf0f5ac486779e8ce778e60c9bb --- tests/parameters.tcl (.../parameters.tcl) (revision a3e419eb3993464990b3f32550892e1bc11124fd) +++ tests/parameters.tcl (.../parameters.tcl) (revision 7efafd7b19c58bf0f5ac486779e8ce778e60c9bb) @@ -77,8 +77,9 @@ ? {::nsf::is switch 1} {invalid value constraints "switch"} ? {::nsf::is superclass M} {invalid value constraints "superclass"} - # don't allow convert - ? {::nsf::is integer,convert 1} {invalid value constraints "integer,convert"} + # don't allow convert; + # well we have to allow it, since "-returns" uses the same mechanism + #? {::nsf::is integer,convert 1} {invalid value constraints "integer,convert"} # tcl checker ? {::nsf::is upper ABC} 1 Index: tests/returns.tcl =================================================================== diff -u -r8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02 -r7efafd7b19c58bf0f5ac486779e8ce778e60c9bb --- tests/returns.tcl (.../returns.tcl) (revision 8c2e2c14e38d6ebb9ef1c44fabcf0229a42c1a02) +++ tests/returns.tcl (.../returns.tcl) (revision 7efafd7b19c58bf0f5ac486779e8ce778e60c9bb) @@ -1,6 +1,14 @@ package require nx; # namespace import -force ::nx::* package require nx::test +# +# The same tests are in this test suite, once with and once without +# checking +# +# Make sure, checking is turned on +# +::nsf::configure checkresult true + Test parameter count 10 Test case int-returns { nx::Class create C { @@ -83,7 +91,7 @@ Test case converting-returns { ::nx::methodParameterSlot method type=sex {name value args} { - #puts stderr "[current] slot specific converter" + #puts stderr "[current] slot specific converter" switch -glob $value { m* {return m} f* {return f} @@ -104,6 +112,21 @@ ::nsf::methodproperty C bar-nok returns sex ::nsf::methodproperty C set returns sex + ? {c1 bar-ok1 1 2} male + ? {c1 bar-ok2 female 2} female + ? {c1 bar-nok 1 6} {expected sex but got 6} + + ? {c1 set x male} male + ? {c1 eval {set :x}} male + ? {c1 set x} male + + ? {c1 set x hugo} {expected sex but got hugo} + + ::nsf::methodproperty C bar-ok1 returns sex,convert + ::nsf::methodproperty C bar-ok2 returns sex,convert + ::nsf::methodproperty C bar-nok returns sex,convert + ::nsf::methodproperty C set returns sex,convert + ? {c1 bar-ok1 1 2} m ? {c1 bar-ok2 female 2} f ? {c1 bar-nok 1 6} {expected sex but got 6} @@ -115,4 +138,143 @@ ? {c1 set x hugo} {expected sex but got hugo} } +# +# turn off result checking +# +::nsf::configure checkresult false +Test parameter count 10 +Test case int-returns-nocheck { + 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} a + + ? {c1 incr x} 1 + ? {c1 incr x} 12 + + ? {c1 lappend l e1} e1 + + # query the returns value + ? {::nsf::methodproperty C lappend returns} integer + + # reset it to emtpy + ? {::nsf::methodproperty C lappend returns ""} "" + + c1 eval {set :l e1} + # 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-nocheck { + + ::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} a + + ? {c1 incr x} 1 + ? {c1 incr x} 12 + + ? {c1 lappend l e1} e1 +} + +Test case converting-returns-nocheck { + + ::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 + } + + # + # turn off checker + # + ::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} male + ? {c1 bar-ok2 female 2} female + ? {c1 bar-nok 1 6} 6 + + ? {c1 set x male} male + ? {c1 eval {set :x}} male + ? {c1 set x} male + + ? {c1 set x hugo} hugo + + # + # don't turn off converter + # + ::nsf::methodproperty C bar-ok1 returns sex,convert + ::nsf::methodproperty C bar-ok2 returns sex,convert + ::nsf::methodproperty C bar-nok returns sex,convert + ::nsf::methodproperty C set returns sex,convert + + ? {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} +}