Index: Makefile.in =================================================================== diff -u -re61fc14f5c25172a1d1f93bea03be54a772fb4b5 -rfe19549734064c3a57866e7e47743ec787f647e5 --- Makefile.in (.../Makefile.in) (revision e61fc14f5c25172a1d1f93bea03be54a772fb4b5) +++ Makefile.in (.../Makefile.in) (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -347,6 +347,7 @@ $(TCLSH) $(src_test_dir_native)/method-modifiers.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/varresolutiontest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/info-method.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/parameters.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/interceptor-slot.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/aliastest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/protected.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) Index: doc/index.html =================================================================== diff -u -r1ddb61a407f327672ce64aa1c1610e7043c10ec7 -rfe19549734064c3a57866e7e47743ec787f647e5 --- doc/index.html (.../index.html) (revision 1ddb61a407f327672ce64aa1c1610e7043c10ec7) +++ doc/index.html (.../index.html) (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -23,7 +23,7 @@

Index: doc/migration1-2.html =================================================================== diff -u -r210eab6d9149846d5d6a6a8e0fa74e232ca5b6de -rfe19549734064c3a57866e7e47743ec787f647e5 --- doc/migration1-2.html (.../migration1-2.html) (revision 210eab6d9149846d5d6a6a8e0fa74e232ca5b6de) +++ doc/migration1-2.html (.../migration1-2.html) (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -173,16 +173,16 @@ C instproc foo args {...}
C instproc bar args {
  my foo 1 2 3 ;# invoke own method
-   o baz        ;# invoke others method
+   o baz       ;# invoke others method
}
Object o
o proc baz {} {...}
Class create C {
  :method foo args {...}
  :method bar args {
-      :foo 1 2 3 ;# invoke own method
-      o baz      ;# invoke others method
+      :foo 1 2 3 ;# invoke own method
+      o baz     ;# invoke others method
  }
}
Object create o {
@@ -688,5 +688,5 @@

- Last modified: Fri Jan 15 13:15:37 CET 2010 + Last modified: Fri Jan 15 13:42:35 CET 2010 Index: generic/gentclAPI.tcl =================================================================== diff -u -r68e773f0a21300bd799c60fefc76f696fd230ca0 -rfe19549734064c3a57866e7e47743ec787f647e5 --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 68e773f0a21300bd799c60fefc76f696fd230ca0) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -306,7 +306,7 @@ puts "enum {\n $enumString\n} XOTclMethods;\n" puts $fns set definitionString [join $ifds ",\n"] - puts "static methodDefinition method_definitions\[\] = \{\n$definitionString\n\};\n" +puts "static methodDefinition method_definitions\[\] = \{\n$definitionString,\{NULL\}\n\};\n" } proc methodDefinition {methodName methodType implementation parameterDefinitions} { Index: generic/tclAPI.h =================================================================== diff -u -r12f68a7ade25ae2bb0fccb8a88583fc0d22edda0 -rfe19549734064c3a57866e7e47743ec787f647e5 --- generic/tclAPI.h (.../tclAPI.h) (revision 12f68a7ade25ae2bb0fccb8a88583fc0d22edda0) +++ generic/tclAPI.h (.../tclAPI.h) (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -2320,6 +2320,6 @@ {"object", 1, 0, convertToObject}, {"-per-object", 0, 0, convertToString}, {"methodName", 1, 0, convertToString}} -} +},{NULL} }; Index: generic/xotcl.c =================================================================== diff -u -r210eab6d9149846d5d6a6a8e0fa74e232ca5b6de -rfe19549734064c3a57866e7e47743ec787f647e5 --- generic/xotcl.c (.../xotcl.c) (revision 210eab6d9149846d5d6a6a8e0fa74e232ca5b6de) +++ generic/xotcl.c (.../xotcl.c) (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -1677,7 +1677,8 @@ if (obj == resVarInfo->lastObj && ((flags & VAR_DEAD_HASH)) == 0) { #if defined(VAR_RESOLVER_TRACE) - fprintf(stderr, ".... cached var '%s' var %p flags = %.4x\n", ObjStr(resVarInfo->nameObj), var, flags); + fprintf(stderr, ".... cached var '%s' var %p flags = %.4x\n", + ObjStr(resVarInfo->nameObj), var, flags); #endif return var; } @@ -1713,7 +1714,8 @@ #if defined(VAR_RESOLVER_TRACE) { Var *v = (Var*)(resVarInfo->var); - fprintf(stderr, ".... looked up var %s (%s) var %p flags = %.6x\n", resVarInfo->buffer, ObjStr(resVarInfo->nameObj), + fprintf(stderr, ".... looked up var %s (%s) var %p flags = %.6x\n", + resVarInfo->buffer, ObjStr(resVarInfo->nameObj), v, v->flags); } #endif @@ -6225,14 +6227,22 @@ } static int convertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { - Tcl_Obj *ov[4]; - int result; + Tcl_Obj *ov[5]; + int result, oc; ov[0] = XOTclGlobalObjects[XOTE_PARAMETER_TYPE_OBJ]; ov[1] = pPtr->arg; ov[2] = pPtr->nameObj; ov[3] = objPtr; - result = Tcl_EvalObjv(interp, 4, ov, 0); + + oc = 4; + if (pPtr->converterArg) { + ov[4] = pPtr->converterArg; + oc++; + } + + result = Tcl_EvalObjv(interp, oc, ov, 0); + if (result == TCL_OK) { *clientData = (ClientData)objPtr; } @@ -6277,57 +6287,61 @@ } static int +ParamOptionSetConverter(Tcl_Interp *interp, XOTclParam *paramPtr, + char *typeName, XOTclTypeConverter *converter) { + if (paramPtr->converter) { + return XOTclVarErrMsg(interp, "Refuse to redefine parameter converter to use ", + typeName, (char *) NULL); + } + paramPtr->converter = converter; + paramPtr->nrArgs = 1; + paramPtr->type = typeName; + return TCL_OK; +} +static int ParamOptionParse(Tcl_Interp *interp, char *option, int length, int disallowedOptions, XOTclParam *paramPtr) { + int result = TCL_OK; + /*fprintf(stderr, "def %s, option '%s' (%d)\n", paramPtr->name, option, length);*/ - if (strncmp(option, "required", length) == 0) { + if (strncmp(option, "required", MAX(3,length)) == 0) { paramPtr->flags |= XOTCL_ARG_REQUIRED; - } else if (strncmp(option, "optional", length) == 0) { + } else if (strncmp(option, "optional", MAX(3,length)) == 0) { paramPtr->flags &= ~XOTCL_ARG_REQUIRED; - } else if (strncmp(option, "substdefault", length) == 0) { + } else if (strncmp(option, "substdefault", 12) == 0) { paramPtr->flags |= XOTCL_ARG_SUBST_DEFAULT; - } else if (strncmp(option, "initcmd", length) == 0) { + } else if (strncmp(option, "initcmd", 7) == 0) { paramPtr->flags |= XOTCL_ARG_INITCMD; - } else if (strncmp(option, "method", length) == 0) { + } else if (strncmp(option, "method", 6) == 0) { paramPtr->flags |= XOTCL_ARG_METHOD; - } else if (strncmp(option, "noarg", length) == 0) { + } else if (strncmp(option, "noarg", 5) == 0) { paramPtr->flags |= XOTCL_ARG_NOARG; paramPtr->nrArgs = 0; } else if (length >= 5 && strncmp(option, "arg=", 4) == 0) { paramPtr->converterArg = Tcl_NewStringObj(option+4, length-4); - } else if (strncmp(option, "switch", length) == 0) { + INCR_REF_COUNT(paramPtr->converterArg); + } else if (strncmp(option, "switch", 6) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "switch", convertToSwitch); paramPtr->nrArgs = 0; - paramPtr->converter = convertToSwitch; assert(paramPtr->defaultValue == NULL); paramPtr->defaultValue = Tcl_NewBooleanObj(0); INCR_REF_COUNT(paramPtr->defaultValue); - paramPtr->type = "switch"; - } else if (strncmp(option, "integer", length) == 0) { - paramPtr->nrArgs = 1; - paramPtr->converter = convertToInteger; - paramPtr->type = "integer"; - } else if (strncmp(option, "boolean", length) == 0) { - paramPtr->nrArgs = 1; - paramPtr->converter = convertToBoolean; - paramPtr->type = "boolean"; - } else if (strncmp(option, "object", length) == 0) { - paramPtr->nrArgs = 1; - paramPtr->converter = convertToObject; - paramPtr->type = "object"; - } else if (strncmp(option, "class", length) == 0) { - paramPtr->nrArgs = 1; - paramPtr->converter = convertToClass; - paramPtr->type = "class"; - } else if (strncmp(option, "relation", length) == 0) { + } else if (strncmp(option, "integer", MAX(3,length)) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "integer", convertToInteger); + } else if (strncmp(option, "boolean", 7) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "boolean", convertToBoolean); + } else if (strncmp(option, "object", 6) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "object", convertToObject); + } else if (strncmp(option, "class", 5) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "class", convertToClass); + } else if (strncmp(option, "relation", 8) == 0) { + result = ParamOptionSetConverter(interp, paramPtr, "relation", convertToRelation); paramPtr->flags |= XOTCL_ARG_RELATION; - paramPtr->nrArgs = 1; - paramPtr->converter = convertToRelation; - paramPtr->type = "tclobj"; + /*paramPtr->type = "tclobj";*/ } else { XOTclObject *paramObj; Tcl_Obj *checker; XOTclClass *pcl; Tcl_Command cmd; - int result; result = GetObjectFromObj(interp, XOTclGlobalObjects[XOTE_PARAMETER_TYPE_OBJ], ¶mObj); if (result != TCL_OK) @@ -6342,18 +6356,15 @@ ObjStr(checker), objectName(paramObj)); /* TODO: for the time being, we do not return an error here */ } - paramPtr->converter = convertViaCmd; - paramPtr->nrArgs = 1; + result = ParamOptionSetConverter(interp, paramPtr, "usertype", convertViaCmd); paramPtr->arg = checker; } if ((paramPtr->flags & disallowedOptions)) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "Parameter option '", option, "' not allowed", (char *) NULL); - return TCL_ERROR; + return XOTclVarErrMsg(interp, "Parameter option '", option, "' not allowed", (char *) NULL); } - - return TCL_OK; + + return result; } static int @@ -6404,7 +6415,7 @@ for (start = j+1; start0 && isspace((int)argString[end-1]); end--); result = ParamOptionParse(interp, argString+start, end-start, disallowedOptions, paramPtr); @@ -9554,9 +9565,9 @@ if (nppPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; if (o < objc) { #if defined(PARSE_TRACE_FULL) - fprintf(stderr, "... setting cd[%d] '%s' = %s (%d) %s\n", - nppPtr-paramPtr, nppPtr->name, ObjStr(objv[p]), nppPtr->nrArgs, - nppPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req"); + fprintf(stderr, "... setting cd[%d] '%s' = %s (%d) %s converter %p\n", + i, nppPtr->name, ObjStr(objv[p]), nppPtr->nrArgs, + nppPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req", nppPtr->converter); #endif if ((*nppPtr->converter)(interp, objv[p], nppPtr, &pcPtr->clientData[nppPtr-paramPtr]) != TCL_OK) { @@ -9610,8 +9621,9 @@ if (dashdash) {dashdash = 0;} if (pPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; - /*fprintf(stderr, "... arg %s req %d converter %p try to set on %d: '%s'\n", - pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED, pPtr->converter, i, ObjStr(objv[o]));*/ + /*fprintf(stderr, "... arg %s req %d converter %p try to set on %d: '%s' convertViaCmd %p\n", + pPtr->name, pPtr->flags & XOTCL_ARG_REQUIRED, pPtr->converter, i, ObjStr(objv[o]), + convertViaCmd);*/ if ((*pPtr->converter)(interp, objv[o], pPtr, &pcPtr->clientData[i]) != TCL_OK) { return TCL_ERROR; } @@ -9620,7 +9632,8 @@ * objv is always passed via pcPtr->objv */ #if defined(PARSE_TRACE_FULL) - fprintf(stderr, "... setting %s pPtr->objv[%d] to [%d]'%s'\n", pPtr->name, i, o, ObjStr(objv[o])); + fprintf(stderr, "... setting %s pPtr->objv[%d] to [%d]'%s' converter %p\n", + pPtr->name, i, o, ObjStr(objv[o]), pPtr->converter); #endif pcPtr->objv[i] = objv[o]; o++; i++; pPtr++; @@ -9799,16 +9812,27 @@ * find the parameter definitions for the C-defined method. */ methodDefinition *mdPtr = &method_definitions[0]; + for (; mdPtr->methodName; mdPtr ++) { + + /*fprintf(stderr, "... comparing %p with %p => %s\n", ((Command *)cmd)->objProc, mdPtr->proc, + mdPtr->methodName);*/ + if (((Command *)cmd)->objProc == mdPtr->proc) { XOTclParamDefs paramDefs = {mdPtr->paramDefs, mdPtr->nrParameters}; Tcl_Obj *list = withVarnames ? ParamDefsList(interp, ¶mDefs) : ParamDefsFormat(interp, ¶mDefs); Tcl_SetObjResult(interp, list); return TCL_OK; } } - return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for method '", - methodName, "'", (char *) NULL); + + if (((Command *)cmd)->objProc == XOTclForwardMethod) { + return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for forwarder '", + methodName, "'", (char *) NULL); + } else { + return XOTclVarErrMsg(interp, "info params: could not obtain parameter definition for method '", + methodName, "'", (char *) NULL); + } } return XOTclErrBadVal(interp, "info params", "a method name", methodName); } @@ -14043,7 +14067,7 @@ } /* create all method commands (will use the namespaces above) */ - for (i=0; i < nr_elements(method_definitions); i++) { + for (i=0; i < nr_elements(method_definitions)-1; i++) { Tcl_CreateObjCommand(interp, method_definitions[i].methodName, method_definitions[i].proc, 0, 0); } Index: generic/xotcl.h =================================================================== diff -u -r210eab6d9149846d5d6a6a8e0fa74e232ca5b6de -rfe19549734064c3a57866e7e47743ec787f647e5 --- generic/xotcl.h (.../xotcl.h) (revision 210eab6d9149846d5d6a6a8e0fa74e232ca5b6de) +++ generic/xotcl.h (.../xotcl.h) (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -79,7 +79,6 @@ #define DOT_CMD_RESOLVER_TRACE 1 */ - /* some features #define TCL85STACK 1 #define CANONICAL_ARGS 1 Fisheye: Tag fe19549734064c3a57866e7e47743ec787f647e5 refers to a dead (removed) revision in file `tests/objparametertest.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/parameters.xotcl =================================================================== diff -u --- tests/parameters.xotcl (revision 0) +++ tests/parameters.xotcl (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -0,0 +1,374 @@ +package require XOTcl +package require xotcl::test + +Test parameter count 10 + +catch {::xotcl::configure cacheinterface true} + +::xotcl::use xotcl2 + +Class create C -parameter {a {b:boolean} {c 1}} +C create c1 +? {C eval {:objectparameter}} "-object-mixin:relation -mixin:relation,arg=class-mixin\ +-superclass:relation -object-filter:relation -filter:relation,arg=filter-mixin\ +-class:relation -parameter:method,optional -noinit:method,optional,noarg\ +-volatile:method,optional,noarg arg:initcmd,optional" + +? {c1 eval {:objectparameter}} \ + "-a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ +-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ +arg:initcmd,optional" +# +# reclass to Object, no need to do anything on caching +# +Test case reclass +c1 class Object +? {c1 eval :objectparameter} "-mixin:relation,arg=object-mixin -filter:relation\ +-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ +arg:initcmd,optional" + +Class create D -superclass C -parameter {d:required} +D create d1 -d 100 + +? {d1 eval :objectparameter} \ + "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ +-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ +arg:initcmd,optional" + +# +# Add mixin +# +Test case objparam-mixins +Class create M -parameter {m1 m2 b} +Class create M2 -parameter {b2} +D mixin M +? {d1 eval :objectparameter} \ + "-b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ +-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ +arg:initcmd,optional" \ + "mixin added" +M mixin M2 +? {d1 eval :objectparameter} \ + "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ +-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ +arg:initcmd,optional" \ + "transitive mixin added" +D mixin "" +#we should have again the old interface + +? {d1 eval :objectparameter} \ + "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ +-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ +arg:initcmd,optional" + +C mixin M +? {d1 eval :objectparameter} \ + "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ +-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ +arg:initcmd,optional" \ + "mixin added" +C mixin "" +#we should have again the old interface + + +? {d1 eval :objectparameter} \ + "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\ +-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\ +arg:initcmd,optional" + + +# +# test passed arguments +# +Test case passed-arguments + +? {catch {D create d1 -d 123}} 0 "create d1 with required argument given" +? {catch {D create d1}} 1 "create d1 without required argument given" +catch {D create d1} errorMsg +? {set _ $errorMsg} "::d1 configure: required argument 'd' is missing" "check error msg" + +? {if {[catch {D create d2 -d x -b a} errorMsg]} {set errorMsg}} \ + {expected boolean value but got "a"} \ + "create d2 without required argument given" + +D create d1 -d 1 +D method foo {-b:boolean -r:required,int {-x:int aaa} {-object:object} {-class:class}} { + #if {[info exists x]} {puts stderr x=$x} +} + +? {if {[catch {d1 foo} errorMsg]} {set errorMsg}} \ + {::d1 foo: required argument 'r' is missing} \ + "call method without a required argument" + +? {if {[catch {d1 foo -r a} errorMsg]} {set errorMsg}} \ + {expected integer but got "a"} \ + "required argument is not integer" + +? {if {[catch {d1 foo -r 1} errorMsg]} {set errorMsg}} \ + {expected integer but got "aaa"} \ + "default value is not of type integer" + +? {if {[catch {d1 foo -r 1 -x 1 -object d1} errorMsg]} {set errorMsg}} \ + "" \ + "pass object" + +? {if {[catch {d1 foo -r 1 -x 1 -object d11} errorMsg]} {set errorMsg}} \ + {Invalid argument: cannot convert 'd11' to object} \ + "pass non-existing object" + +? {if {[catch {d1 foo -r 1 -x 1 -class D} errorMsg]} {set errorMsg}} \ + "" \ + "pass class" + +? {if {[catch {d1 foo -r 1 -x 1 -class d1} errorMsg]} {set errorMsg}} \ + {Invalid argument: cannot convert 'd1' to class} \ + "pass object instead of class" + +? {if {[catch {d1 foo -r 1 -x 1 -class D11} errorMsg]} {set errorMsg}} \ + {Invalid argument: cannot convert 'D11' to class} \ + "pass non-existing class" + +? {if {[catch {D method foo {a:relation} {}} errorMsg]} {set errorMsg}} \ + {Parameter option 'relation' not allowed} \ + "don't allow relation option as method parameter" + +# +# non required positional arguments +# +Test case non-reg-args + +D method foo {a b:optional c:optional} { + return "[info exists a]-[info exists b]-[info exists c]" +} +? {d1 foo 1 2} "1-1-0" "omit optional argument" +? {d1 foo 1} "1-0-0" "omit optional arguments" + +# non required positional arguments and args +D method foo {a b:optional c:optional args} { + return "[info exists a]-[info exists b]-[info exists c]-[info exists args]" +} +? {d1 foo 1 2} "1-1-0-1" "omit optional argument" +? {d1 foo 1} "1-0-0-1" "omit optional arguments" + + +# +# subst default tests +# +Test case subst-default + +D method bar { + {-s:substdefault "[self]"} + {-literal "[self]"} + {-c:substdefault "[my c]"} + {-d:integer,substdefault "$d"} +} { + return $s-$literal-$c-$d +} + +? {d1 bar -c 1} {::d1-[self]-1-1} "substdefault on method" + +Class create Bar -superclass D -parameter { + {s "[self]"} + {literal "\\[self\\]"} + {c "[my info class]"} + {d "$d"} +} +Bar create bar1 +#puts stderr [bar1 objectparameter] + +? {subst {[bar1 s]-[bar1 literal]-[bar1 c]-[bar1 d]}} \ + {::bar1-[self]-::Bar-$d} \ + "substdefault on object" + +# Observations: +# 1) syntax for "-parameter" and method parameter is quite different. +# it would be nice to be able to specify the objparameters in +# the same syntax as the method parameters. +# +# 1a) Especially specifying "-" in front of a -parameter or not might +# be confusing. +# +# 1b) Positional args for obj parameter and arguments for init +# might be confusing as well. Should we forget about +# passing arguments to init? +# +# 2) substdefault for '$' in -parameter defaults does not make much sense. +# deactivated for now; otherwise we would need "\\" + +D method bar { + {-s:substdefault "[self]"} + {-literal "[self]"} + {-c:substdefault "[my c]"} + {-d:integer,substdefault "$d"} + {-switch:switch} + {-optflag} + x + y:integer + {z 1} +} { + return $s-$literal-$c-$d +} + +? {D info method args bar} {s literal c d switch optflag x y z} "all args" +? {D info method parameter bar} \ + {{-s:substdefault {[self]}} {-literal {[self]}} {-c:substdefault {[my c]}} {-d:integer,substdefault {$d}} {-switch:switch 0} -optflag x y:integer {z 1}} \ + "query method parameter" + +D method foo {a b {-c 1} {-d} x {-end 100}} { + set result [list] + foreach v [[self class] info method args [self proc]] { + lappend result $v [info exists $v] + } + return $result +} +? {d1 foo 1 2 3} \ + "a 1 b 1 c 1 d 0 x 1 end 1" \ + "parse multiple groups of nonpos args" + +D method foo {a b c {end 100}} { + set result [list] + foreach v [[self class] info method args [self proc]] { + lappend result $v [info exists $v] + } + return $result +} +? {d1 foo 1 2 3} \ + "a 1 b 1 c 1 end 1" \ + "query arguments with default, no paramdefs needed" + +# +# Query method parameter +# +Test case query-method-parameter + +? {D info method parameter foo} \ + "a b c {end 100}" \ + "query instparams with default, no paramdefs needed" + +? {Class info method parameter method} \ + "name arguments body -precondition -postcondition" \ + "query instparams for scripted method 'method'" + +? {catch {Object info method parameter forward}} \ + "1" \ + "query parameter for C-defined method 'forward'" + +? {Object info method parameter autoname} \ + "-instance -reset name" \ + "query parameter for C-defined method 'autoname'" + +# TODO: how to query the params/instparams of info subcommands? +#? {::xotcl::objectInfo info params params} \ +# "xxx" \ +# "query instparams for info method 'params' method" + + +# +# user defined parameter types +# +Test case user-types + +# +# create class and object for nonpositional argument processing +Class create ::xotcl::ParameterType +foreach cmd [info command ::xotcl::cmd::ParameterType::*] { + ::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd +} +# create an object for dispatching +::xotcl::ParameterType create ::xotcl::parameterType + +# create a userdefined type +::xotcl::parameterType method type=mytype {name value args} { + if {$value < 1 || $value > 3} { + error "Value '$value' of parameter $name is not between 1 and 3" + } +} + +D method foo {a:mytype} { + puts stderr a=$a +} +d1 foo 1 + +catch {d1 foo 10} errorMsg +? {set ::errorMsg} \ + "Value '10' of parameter a is not between 1 and 3" \ + "invalid value" + +D method foo {a:unknowntype} { + puts stderr a=$a +} + +catch {d1 foo 10} errorMsg +? {set ::errorMsg} \ + "::xotcl::parameterType: unable to dispatch method 'type=unknowntype'" \ + "missing type checker" + +# create a userdefined type with a simple argument +::xotcl::parameterType method type=in {name value arg} { + if {$value ni [split $arg |]} { + error "Value '$value' of parameter $name not in permissible values $arg" + } +} + +D method foo {a:in,arg=a|b|c} { + return a=$a +} + +? {d1 foo a} "a=a" +catch {d1 foo 10} errorMsg +? {set ::errorMsg} \ + "Value '10' of parameter a not in permissible values a|b|c" \ + "invalid value" + +D method foo {a:in,arg=a|b|c b:in,arg=good|bad {-c:in,arg=a|b a}} { + return a=$a,b=$b,c=$c +} + +? {d1 foo a good -c b} "a=a,b=good,c=b" +? {d1 foo a good} "a=a,b=good,c=a" +catch {d1 foo b "very good"} errorMsg +? {set ::errorMsg} \ + "Value 'very good' of parameter b not in permissible values good|bad" \ + "invalid value (not included)" + +::xotcl::parameterType 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" + } +} + +D method foo {a:range,arg=1-3 {-b:range,arg=2-6 3} c:range,arg=5-10} { + return a=$a,b=$b,c=$c +} + +? {d1 foo 2 -b 4 9} "a=2,b=4,c=9" +? {d1 foo 2 10} "a=2,b=3,c=10" +catch {d1 foo 2 11} errorMsg +? {set ::errorMsg} \ + "Value '11' of parameter c not between 5 and 10" \ + "invalid value" + +# define type twice +catch {D method foo {a:int,range,arg=1-3} {return a=$a}} errorMsg +? {set ::errorMsg} \ + "Refuse to redefine parameter converter to use usertype" \ + "invalid value" + +# +# handling of arg with spaces/arg as list +# +::xotcl::parameterType method type=list {name value arg} { + #puts $value/$arg +} + +# handling spaces in "arg" is not not particular nice +D method foo {{"-a:list,arg=2 6" 3} {"b:list,arg=5 10"}} { + return a=$a,b=$b +} +? {d1 foo -a 2 10} "a=2,b=10" + + +## TODO regression test for type checking, parameter options (initcmd, +## substdefault, combinations with defaults, ...), etc. +puts stderr =====END Index: tests/testx.xotcl =================================================================== diff -u -re5b7b9261b0de87bf7a45ff7416ecd967037fa0b -rfe19549734064c3a57866e7e47743ec787f647e5 --- tests/testx.xotcl (.../testx.xotcl) (revision e5b7b9261b0de87bf7a45ff7416ecd967037fa0b) +++ tests/testx.xotcl (.../testx.xotcl) (revision fe19549734064c3a57866e7e47743ec787f647e5) @@ -3924,15 +3924,15 @@ lappend ::r "reddish <$var> <$value>" } - o proc z4 { - {{-b: required, checkobj colorchecker,color, reddish, - checkobj xotcl::nonposArgs,required} red} - {{-c: required }} - arg - } { - lappend ::r "$b $arg" - return "$b $arg" - } +# o proc z4 { +# {{-b: required, checkobj colorchecker,color, reddish, +# checkobj xotcl::nonposArgs,required} red} +# {{-c: required }} +# arg +# } { +# lappend ::r "$b $arg" +# return "$b $arg" +# } o proc z5 {-pos args} { return [list $pos $args] } @@ -3994,7 +3994,7 @@ errorCheck [o info body z2] {return "$x -- $args -- $a -- $b"} "info body 1" errorCheck [P info instbody z2] {return "$x -- $args -- $a -- $b"} "info instbody z2" - errorCheck [o info args z4] {arg} "info args" +# errorCheck [o info args z4] {arg} "info args" # errorCheck [o info nonposargs z4] "{{-b:required,checkobj colorchecker,color,reddish,checkobj xotcl::nonposArgs,required} red} -c:required" "info nonposargs 1" errorCheck [o info nonposargs x] {} "info nonposargs 2" errorCheck [P info instargs z3] {a b c} "info instargs"