# -*- Tcl -*- package require nx package require nx::test #::nx::configure defaultMethodCallProtection false namespace import ::nx::* Test case dummy { ? {::namespace current} :: set o [Object create o] ? {::nsf::isobject ::o} 1 } ? {::nsf::isobject ::o} 0 ####################################################### # parametercheck ####################################################### Test parameter count 1000 Test case parametercheck { Object create o1 Class create C -attributes {a {b:boolean} {c 1}} C create c1 Class create M c1 mixin M ? {::nsf::isobject o1} 1 ? {::nsf::isobject o1000} 0 ? {::nsf::is class C} 1 ? {C info is class} 1 ? {::nsf::is baseclass ::nx::Object} 1 ? {::nx::Object info is baseclass} 1 ? {::nsf::is baseclass C} 0 ? {C info is baseclass} 0 ? {::nsf::is class ::nx::Object} 1 ? {::nsf::is ::nx::Object class} {invalid value constraints "::nx::Object"} ? {::nsf::is object o1} 1 ? {::nsf::is object o1} 1 ? {::nsf::is object o1000} 0 ? {::nsf::is -complain object o1000} {expected object but got "o1000"} ? {::nsf::is integer 1} 1 ? {::nsf::is object,type=::C c1} 1 ? {::nsf::is -complain object,type=::C o} {expected object but got "o"} ? {::nsf::is object,type=::C o} 0 ? {c1 info has mixin ::M} 1 ? {c1 info has mixin ::M1} {expected class but got "::M1" for parameter "class"} ? {c1 info has type C} 1 ? {c1 info has type C1} {expected class but got "C1" for parameter "class"} ? {c1 ::nsf::methods::object::info::hastype C} 1 ? {::nsf::dispatch c1 ::nsf::methods::object::info::hastype C} 1 ? {::nsf::is object o1} 1 ? {::nsf::is object o100} 0 ? {::nsf::is integer 1} 1 ? {::nsf::is object,type=::C c1} 1 ? {::nsf::is object,type=::C o} 0 # test built-in converter via ::nsf::is ? {::nsf::is boolean 1} 1 ? {::nsf::is boolean on} 1 ? {::nsf::is boolean true} 1 ? {::nsf::is boolean t} 1 ? {::nsf::is boolean f} 1 ? {::nsf::is boolean a} 0 ? {::nsf::is integer 0x0} 1 ? {::nsf::is integer 0xy} 0 # built in converter, but not allowed ? {::nsf::is switch 1} {invalid value constraints "switch"} ? {::nsf::is superclass M} {invalid value constraints "superclass"} # 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 ? {::nsf::is upper Abc} 0 ? {::nsf::is lower Abc} 0 ? {::nsf::is lower abc} 1 #? {::nsf::is type c1 C} 1 #? {::nsf::is type o C} 0 #? {::nsf::is object o -type C} 0 #? {::nsf::is object o -hasmixin C} 0 # scripted checker ? {::nsf::is metaclass ::nx::Class} 1 ? {::nsf::is metaclass ::nx::Object} 0 ? {::nsf::is -complain class o1} {expected class but got "o1"} ? {::nsf::is class o1} 0 ? {::nsf::is -complain class Test} 1 ? {::nsf::is -complain object,1..* [list o1 Test]} 1 ? {::nsf::is -complain integer,1..* [list 1 2 3]} 1 ? {::nsf::is -complain integer,1..* [list 1 2 3 a]} \ {invalid value in "1 2 3 a": expected integer but got "a"} ? {::nsf::is -complain object,type=::C c1} 1 ? {::nsf::is -complain object,type=::C o} \ {expected object but got "o"} \ "object, but different type" ? {::nsf::is -complain object,type=::C c} \ {expected object but got "c"} \ "no object" ? {::nsf::is -complain object,type=::nx::Object c1} 1 "general type" # do not allow "currently unknown" user defined types in parametercheck ? {::nsf::is -complain in1 aaa} {invalid value constraints "in1"} ? {::nsf::is -complain lower c} 1 "lower case char" ? {::nsf::is -complain lower abc} 1 "lower case chars" ? {::nsf::is -complain lower Abc} {expected lower but got "Abc"} ? {string is lower abc} 1 "tcl command 'string is lower'" ? {::nsf::is -complain {i:integer 1} 2} {invalid value constraints "i:integer 1"} } Test parameter count 10 Test case multiple-method-checkers { Object create o { :public method foo {} { ::nsf::is metaclass ::XYZ ::nsf::is metaclass ::nx::Object } :public method bar {} { ::nsf::is metaclass ::XYZ ::nsf::is metaclass ::XYZ } :public method bar2 {} { ::nsf::is metaclass ::nx::Object ::nsf::is metaclass ::nx::Object } } ? {o foo} 0 ? {o bar} 0 ? {::nsf::is metaclass ::XYZ} 0 ? {::nsf::is metaclass ::nx::Object} 0 ? {o foo} 0 ? {o bar2} 0 } ####################################################### # parametercheck ####################################################### Test parameter count 10000 Test case parametercheck { Object create ::paramManager { :method type=sex {name value} { return "agamous" } } ? {::nsf::is -complain sex,slot=::paramManager female} "1" } ####################################################### # cononical feature table ####################################################### # # parameter options # required # optional # multivalued # noarg # arg= # substdefault: if no value given, subst on default (result is substituted value); # susbt cmd can use variable resolvers, # works for scripted/c-methods and obj-parm, # autmatically set by "$slot toParameterSyntax" if default contains "[" ... "]". # # initcmd: evaluate body in an xotcl nonleaf frame, called via configure # (example: last arg on create) # method call specified method in an xotcl nonleaf frame, called via configure; # specified value is the first argument unless "noarg" is used # (example: -noinit). # # parameter type multivalued required noarg type= arg= parametercheck methodParm objectParm # initcmd NO YES NO NO NO NO NO/POSSIBLE YES # method NO YES YES NO YES NO NO/POSSIBLE YES # # relation NO YES NO NO YES NO NO YES # stringtype YES YES NO NO NO YES YES YES # # switch NO NO NO NO NO NO YES NO # integer YES YES NO NO NO YES YES YES # boolean YES YES NO NO NO YES YES YES # object YES YES NO YES NO YES YES YES # class YES YES NO YES NO YES YES YES # # userdefined YES YES NO NO YES YES YES YES # # tclObj + converterArg (alnum..xdigit) Attribute ... -type alnum # object + converterArg (some class, e.g. ::C) Attribute ... -type ::C Attribute -type object -arg ::C # class + converterArg (some metaclass, e.g. ::M) Attribute -type class -arg ::M # # #::xotcl::Slot { # {name "[namespace tail [::xotcl::self]]"} # {methodname} # {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]"} # {defaultmethods {get assign}} # {manager "[::xotcl::self]"} # {multivalued false} # {per-object false} # {required false} # default # type # } -- No instances # # ::xotcl::RelationSlot -superclass ::xotcl::Slot { # {multivalued true} # {type relation} # {elementtype ::nx::Class} # } -- sample instances: class superclass, mixin filter # # ::nx::Attribute -superclass ::xotcl::Slot { # {value_check once} # defaultcmd # valuecmd # valuechangedcmd # arg # } -- typical object parameters # # MethodParameterSlot -attributes {type required multivalued noarg arg} # -- typical method parameters ####################################################### # objectparameter ####################################################### Test parameter count 10 Test case objectparameter { Class create C -attributes {a {b:boolean} {c 1}} C create c1 ? {C eval {:objectparameter}} \ "-object-mixin:relation,slot=::nx::Class::slot::object-mixin -mixin:relation,arg=class-mixin,slot=::nx::Class::slot::mixin -superclass:relation,slot=::nx::Class::slot::superclass -object-filter:relation,slot=::nx::Class::slot::object-filter -filter:relation,arg=class-filter,slot=::nx::Class::slot::filter -attributes:method,optional -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd: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=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" } ####################################################### # reclass to Object, no need to do anything on caching ####################################################### Test case reclass { Class create C -attributes {a {b:boolean} {c 1}} C create c1 c1 class Object ? {c1 eval :objectparameter} \ "-mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" Class create D -superclass C -attributes {d:required} D create d1 -d 100 ? {d1 eval :objectparameter} \ "-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" } ####################################################### # Add mixin ####################################################### Test case objparam-mixins { Class create C -attributes {a {b:boolean} {c 1}} Class create D -superclass C -attributes {d:required} D create d1 -d 100 Class create M -attributes {m1 m2 b} Class create M2 -attributes {b2} D mixin M ? {d1 eval :objectparameter} \ "-b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" \ "mixin added" M mixin M2 ? {d1 eval :objectparameter} \ "-b2:slot=::M2::slot::b2 -b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" \ "transitive mixin added" D mixin "" #we should have again the old interface ? {d1 eval :objectparameter} \ "-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" C mixin M ? {d1 eval :objectparameter} \ "-b2:slot=::M2::slot::b2 -b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" \ "mixin added" C mixin "" #we should have again the old interface ? {d1 eval :objectparameter} \ "-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" } ####################################################### # test passed arguments ####################################################### Test case passed-arguments { Class create C -attributes {a {b:boolean} {c 1}} Class create D -superclass C -attributes {d:required} ? {catch {D create d1 -d 123}} 0 "create d1 with required argument given" ? {catch {D create d1}} 1 "create d1 without required argument given" #puts stderr current=[namespace current] ? {D create d1} "::d1 configure: required argument 'd' is missing" "check error msg" ? {D create d2 -d x -b a} \ {expected boolean but got "a" for parameter "-b"} \ "create d2 without required argument given" D create d1 -d 1 D public method foo {-b:boolean -r:required,int {-x:int aaa} {-object:object} {-class:class}} { #if {[info exists x]} {puts stderr x=$x} } ? {d1 foo} \ "::d1 foo: required argument 'r' is missing" \ "call method without a required argument" ? {d1 foo -r a} \ {expected integer but got "a" for parameter "-r"} \ "required argument is not integer" ? {d1 foo -r 1} \ {expected integer but got "aaa" for parameter "-x"} \ "default value is not of type integer" ? {d1 foo -r 1 -x 1 -object d1} \ "" \ "pass object" ? {d1 foo -r 1 -x 1 -object d11} \ {expected object but got "d11" for parameter "-object"} \ "pass non-existing object" ? {d1 foo -r 1 -x 1 -class D} \ "" \ "pass class" ? {d1 foo -r 1 -x 1 -class d1} \ {expected class but got "d1" for parameter "-class"} \ "pass object instead of class" ? {d1 foo -r 1 -x 1 -class D11} \ {expected class but got "D11" for parameter "-class"} \ "pass non-existing class" ? {D public method foo {a:relation} {}} \ {Parameter option 'relation' not allowed} \ "don't allow relation option as method parameter" ? {D public method foo {a:double} {return $a}} \ {::nsf::classes::D::foo} \ "allow 'string is XXXX' for argument checking" ? {d1 foo 1} 1 "check int as double" ? {d1 foo 1.1} 1.1 "check double as double" ? {d1 foo 1.1a} {expected double but got "1.1a" for parameter "a"} "check non-double as double" ? {D info method parameter foo} a:double } ####################################################### # non required positional arguments ####################################################### Test case non-reg-args { Class create D D create d1 D public 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 public 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" } ####################################################### # multivalued arguments ####################################################### Test case multivalued { Class create D D create d1 Object create o D public method foo {m:integer,0..n} { return $m } ? {d1 foo ""} "" "emtpy list" ? {d1 foo 1} "1" "single value" ? {d1 foo {1 2}} "1 2" "multiple values" ? {d1 foo {1 a 2}} \ {invalid value in "1 a 2": expected integer but got "a" for parameter "m"} \ "multiple values with wrong value" D public method foo {m:object,0..n} { return $m } ? {d1 foo ""} "" "emtpy list" ? {d1 foo o} "o" "single value" ? {d1 foo {o d1 x}} \ {invalid value in "o d1 x": expected object but got "x" for parameter "m"} \ "multiple values" Class create Foo -attributes { {ints:integer,1..*} } ? {Foo create foo -ints {1 2}} "::foo" ? {Foo create foo -ints {1 a 2}} {invalid value in "1 a 2": expected integer but got "a" for parameter "-ints"} # make slot incremental Foo::slot::ints eval { set :incremental 1 :optimize } Foo create foo -ints {1 2} ? {foo ints add 0} "0 1 2" ? {foo ints add a} {expected integer but got "a" for parameter "value"} } ####################################################### # subst default tests ####################################################### Test case subst-default { Class create D { :attribute {c 1} :attribute {d 2} :create d1 :public method bar { {-s:substdefault "[current]"} {-literal "[current]"} {-c:substdefault "[my c]"} {-d:integer,substdefault "$d"} } { return $s-$literal-$c-$d } } ? {d1 bar -c 1} {::d1-[current]-1-2} "substdefault in method parameter" Class create Bar -superclass D -attributes { {s "[current]"} {literal "\\[current\\]"} {c "[:info class]"} {d "literal $d"} } ? {Bar attribute ss:switch} "switch is not allowed as type for object parameter ss" Bar create bar1 #puts stderr [bar1 objectparameter] ? {subst {[bar1 s]-[bar1 literal]-[bar1 c]-[bar1 d]}} \ {::bar1-[current]-::Bar-literal $d} \ "substdefault in object parameter 1" Bar create bar2 ? {subst {[bar2 s]-[bar2 literal]-[bar2 c]-[bar2 d]}} \ {::bar2-[current]-::Bar-literal $d} \ "substdefault in object parameter 2" # Observations: # 1) syntax for "-attributes" 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 -attributes 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 -attributes defaults does not make much sense. # deactivated for now; otherwise we would need "\\" D public method bar { {-s:substdefault "[current]"} {-literal "[current]"} {-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 "[current]"} {-literal "[current]"} {-c:substdefault "[my c]"} {-d:integer,substdefault "$d"} -switch:switch -optflag x y:integer {z 1}} \ "query method parameter" ? {D public method foo {s:switch} {return 1}} \ {invalid parameter type "switch" for argument "s"; type "switch" only allowed for non-positional arguments} D public method foo {a b {-c 1} {-d} x {-end 100}} { set result [list] foreach v [[current class] info method args [current method]] { 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 public method foo {a b c {end 100}} { set result [list] foreach v [[current class] info method args [current method]] { 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 ####################################################### ? {D info method parameter foo} \ "a b c {end 100}" \ "query instparams with default, no paramdefs needed" ? {Class info method parameter method} \ "name arguments:parameter,0..* -returns body -precondition -postcondition" \ "query instparams for scripted method 'method'" ? {Object info method parameter ::nsf::forward} \ "object -per-object:switch method -default -earlybinding:switch -methodprefix -objframe:switch -onerror -verbose:switch target:optional args" \ "query parameter for C-defined cmd 'nsf::forward'" Object require method autoname ? {Object info method parameter autoname} \ "-instance:switch -reset:switch 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 { Class create D -attributes d D create d1 # create a userdefined type ::nx::methodParameterSlot method type=mytype {name value args} { if {$value < 1 || $value > 3} { error "Value '$value' of parameter $name is not between 1 and 3" } } D public method foo {a:mytype} { return a=$a } d1 foo 1 ? {d1 foo 10} \ "Value '10' of parameter a is not between 1 and 3" \ "value not between 1 and 3" D public method foo {a:unknowntype} { return $a } ? {d1 foo 10} \ "::nx::methodParameterSlot: unable to dispatch method 'type=unknowntype'" \ "missing type checker" # create a userdefined type with a simple argument ::nx::methodParameterSlot method type=in {name value arg} { if {$value ni [split $arg |]} { error "Value '$value' of parameter $name not in permissible values $arg" } return $value } D public method foo {a:in,arg=a|b|c} { return a=$a } ? {d1 foo a} "a=a" ? {d1 foo 10} \ "Value '10' of parameter a not in permissible values a|b|c" \ "invalid value" D public 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" ? {d1 foo b "very good"} \ "Value 'very good' of parameter b not in permissible values good|bad" \ "invalid value (not included)" ::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 } D public 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" ? {d1 foo 2 11} \ "Value '11' of parameter c not between 5 and 10" \ "invalid value" # define type twice ? {D public method foo {a:int,range,arg=1-3} {return a=$a}} \ "Refuse to redefine parameter converter to use type=range" \ "invalid value" # # handling of arg with spaces/arg as list # ::nx::methodParameterSlot public method type=list {name value arg} { #puts $value/$arg return $value } # handling spaces in "arg" is not not particular nice D public 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" } ####################################################### # testing object types in method parameters ####################################################### Test case mp-object-types { Class create C Class create D -superclass C -attributes d Class create M D create d1 -d 1 C create c1 -mixin M Object create o D public method foo-base {x:baseclass} {return $x} D public method foo-class {x:class} {return $x} D public method foo-object {x:object} {return $x} D public method foo-meta {x:metaclass} {return $x} D public method foo-type {x:object,type=::C} {return $x} ? {D info method parameter foo-base} "x:baseclass" ? {D info method parameter foo-type} "x:object,type=::C" ? {d1 foo-base ::nx::Object} "::nx::Object" ? {d1 foo-base C} \ {expected baseclass but got "C" for parameter "x"} \ "not a base class" ? {d1 foo-class D} "D" ? {d1 foo-class xxx} \ {expected class but got "xxx" for parameter "x"} \ "not a class" ? {d1 foo-class o} \ {expected class but got "o" for parameter "x"} \ "not a class" ? {d1 foo-meta ::nx::Class} "::nx::Class" ? {d1 foo-meta ::nx::Object} \ {expected metaclass but got "::nx::Object" for parameter "x"} \ "not a base class" ? {d1 foo-object o} "o" ? {d1 foo-object xxx} \ {expected object but got "xxx" for parameter "x"} \ "not an object" ? {d1 foo-type d1} "d1" ? {d1 foo-type c1} "c1" ? {d1 foo-type o} \ {expected object of type ::C but got "o" for parameter "x"} \ "o not of type ::C" } ####################################################### # substdefault ####################################################### Test case substdefault { Class create S -attributes {{x 1} {y b} {z {1 2 3}}} S create s1 { :public method foo {{y:substdefault ${:x}}} { return $y } :public method bar {{y:integer,substdefault ${:x}}} { return $y } :public method baz {{x:integer,substdefault ${:y}}} { return $x } :public method boz {{x:integer,0..n,substdefault ${:z}}} { return $x } } ? {s1 foo} 1 ? {s1 foo 2} 2 ? {S method foo {a:substdefault} {return 1}} \ {parameter option substdefault specified for parameter "a" without default value} ? {s1 bar} 1 ? {s1 bar 3} 3 ? {s1 bar a} {expected integer but got "a" for parameter "y"} ? {s1 baz} {expected integer but got "b" for parameter "x"} ? {s1 baz 20} 20 s1 y 100 ? {s1 baz} 100 ? {s1 baz 101} 101 ? {s1 boz} {1 2 3} s1 z {1 x 100} ? {s1 boz} {invalid value in "1 x 100": expected integer but got "x" for parameter "x"} ? {s1 boz {100 200}} {100 200} set ::aaa 100 ? {s1 public method foo {{a:substdefault $::aaa}} {return $a}} ::s1::foo ? {s1 foo} 100 unset ::aaa ? {s1 foo} {can't read "::aaa": no such variable} ? {s1 public method foo {{a:substdefault $aaa}} {return $a}} ::s1::foo ? {s1 foo} {can't read "aaa": no such variable} ? {s1 public method foo {{a:substdefault [current]}} {return $a}} ::s1::foo ? {s1 foo} ::s1 } ####################################################### # testing substdefault for object parameters ####################################################### Test case substdefault-objparam { Class create Bar { # simple, implicit substdefault :attribute {s0 "[current]"} # explicit substdefault :attribute {s1:substdefault "[current]"} # unneeded double substdefault :attribute {s2:substdefault,substdefault "[current]"} # substdefault with incremental :attribute {s3:substdefault "[current]"} { # Bypassing the Optimizer helps after applying the patch (solving step 1) set :incremental 1 } } Bar create ::b ? {b s0} "::b" ? {b s1} "::b" ? {b s2} "::b" ? {b s3} "::b" } ####################################################### # testing object types in object parameters ####################################################### Test case op-object-types { Class create C Class create D -superclass C -attributes d Class create MC -superclass Class MC create MC1 Class create M D create d1 -d 1 C create c1 -mixin M Object create o Class create ParamTest -attributes { o:object c:class c1:class,type=::MC d:object,type=::C d1:object,type=C m:metaclass b:baseclass u:upper us:upper,1..* {x:object,1..* {o}} } # TODO: we have no good interface for querying the slot notation for parameters proc ::parameterFromSlot {class objectparameter} { set slot ${class}::slot::$objectparameter array set "" [$slot toParameterSyntax $objectparameter] return $(oparam) } ? {::parameterFromSlot ParamTest o} "o:object,slot=::ParamTest::slot::o" ? {::parameterFromSlot ParamTest c} "c:class,slot=::ParamTest::slot::c" ? {::parameterFromSlot ParamTest c1} "c1:class,type=::MC,slot=::ParamTest::slot::c1" ? {::parameterFromSlot ParamTest d} "d:object,type=::C,slot=::ParamTest::slot::d" ? {::parameterFromSlot ParamTest d1} "d1:object,type=::C,slot=::ParamTest::slot::d1" #? {::parameterFromSlot ParamTest mix} "mix:hasmixin,arg=M,slot=::ParamTest::slot::mix" ? {::parameterFromSlot ParamTest x} "x:object,1..*,slot=::ParamTest::slot::x o" ? {::parameterFromSlot ParamTest u} "u:upper,slot=::ParamTest::slot::u" ? {::parameterFromSlot ParamTest us} "us:upper,1..*,slot=::ParamTest::slot::us" ? {ParamTest create p -o o} ::p ? {ParamTest create p -o xxx} \ {expected object but got "xxx" for parameter "-o"} \ "not an object" ? {ParamTest create p -c C} ::p "class" ? {ParamTest create p -c o} \ {expected class but got "o" for parameter "-c"} \ "not a class" ? {ParamTest create p -c1 MC1} ::p "instance of meta-class MC" ? {ParamTest create p -c1 C} \ {expected class of type ::MC but got "C" for parameter "-c1"} \ "not an instance of meta-class MC" ? {ParamTest create p -d d1} ::p ? {ParamTest create p -d1 d1} ::p ? {ParamTest create p -d c1} ::p ? {ParamTest create p -d o} \ {expected object of type ::C but got "o" for parameter "-d"} \ "o not of type ::C" #? {ParamTest create p -mix c1} ::p #? {ParamTest create p -mix o} \ {expected object with mixin M but got "o" for parameter "mix"} \ "does not have mixin M" ? {ParamTest create p -u A} ::p ? {ParamTest create p -u c1} {expected upper but got "c1" for parameter "-u"} ? {ParamTest create p -us {A B c}} \ {invalid value in "A B c": expected upper but got "c" for parameter "-us"} ParamTest::slot::us eval { set :incremental 1 :optimize } ? {ParamTest create p -us {A B}} ::p ? {p us add C end} "A B C" ? {p o o} \ "o" \ "value is an object" ? {p o xxx} \ {expected object but got "xxx" for parameter "o"} \ "value is not an object" #ParamTest slots { # ::nx::Attribute create os -type object -multivalued true #} ParamTest eval { :attribute os { :type object :multivalued true } } ? {p os o} \ "o" \ "value is a list of objects (1 element)" ? {p os {o c1 d1}} \ "o c1 d1" \ "value is a list of objects (multiple elements)" ? {p os {o xxx d1}} \ {invalid value in "o xxx d1": expected object but got "xxx" for parameter "os"} \ "list with invalid object" } ####################################################### # application specific multivalued converter ####################################################### Test case multivalued-app-converter { ::nx::methodParameterSlot public 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"} } } Class create C { :public method foo {s:sex,0..*,convert} {return $s} :public method bar {s:sex,0..*} {return $s} } C create c1 ? {c1 foo {male female mann frau}} "m f m f" ? {c1 bar {male female mann frau}} "male female mann frau" Object create tmpObj tmpObj method type=mType {name value arg:optional} { if {$value} { error "expected false but got $value" } # Note that this converter does NOT return a value; it converts all # values into emtpy strings. } ? {::nsf::is -complain mType,slot=::tmpObj,0..* {1 0}} \ {invalid value in "1 0": expected false but got 1} \ "fail on first value" ? {::nsf::is -complain mType,slot=::tmpObj,0..* {0 0 0}} 1 "all pass" ? {::nsf::is -complain mType,slot=::tmpObj,0..* {0 1}} \ {invalid value in "0 1": expected false but got 1} \ "fail o last value" } ####################################################### # application specific multivalued converter ####################################################### Test case shadowing-app-converter { Object create mySlot { :public method type=integer {name value arg:optional} { return [expr {$value + 1}] } } Object create o { :public method foo {x:integer,slot=::mySlot,convert} { return $x } } ? {::nsf::is -complain integer,slot=::mySlot 1} 1 ? {o foo 3} 4 } ####################################################### # allow empty values ####################################################### Test case allow-empty { Object create o1 Object create o2 Object create o3 Object create o { :public method foo {x:integer,0..1 y:integer os:object,0..*} { return $x } } ? {o foo 1 2 {o1 o2}} 1 "all values specified" ? {o foo "" 2 {o1 o2}} "" "first is empty" ? {o foo 1 "" {o1 o2}} {expected integer but got "" for parameter "y"} "second is empty" ? {o foo 1 2 {}} 1 "empty list" # TODO allowempty change #? {o foo 1 2 {o1 "" o2}} 1 "list contains empty value" ? {o info method parameter foo} "x:integer,0..1 y:integer os:object,0..*" o public method foo {x:integer,0..1 y:integer os:object,1..*} {return $x} ? {o foo 1 2 {o1 "" o2}} {invalid value in "o1 "" o2": expected object but got "" for parameter "os"} \ "list contains empty value" ? {o foo "" 2 {}} {invalid parameter value: list is not allowed to be empty} \ "empty int, empty list of objects" } ####################################################### # slot specific converter ####################################################### Test case slot-specfic-converter { Class create Person { :attribute sex { :type "sex" :convert true :method type=sex {name value} { #puts stderr "[self] slot specific converter" switch -glob $value { m* {return m} f* {return f} default {error "expected sex but got $value"} } } } } Person create p1 -sex male ? {p1 sex} m Person public method foo {s:sex,slot=::Person::slot::sex,convert} {return $s} ? {p1 foo male} m ? {p1 sex male} m } ####################################################### # test for setters with parameters ####################################################### Test case setters { Object create o Class create C ? {::nsf::setter ::o :a} {invalid setter name ":a" (must not start with a dash or colon)} ? {::nsf::setter o a} "::o::a" ? {::nsf::setter C c} "::nsf::classes::C::c" ? {o info method definition a} "::o public setter a" ? {o info method parameter a} "a" ? {o info method args a} "a" ? {C info method definition c} "::C public setter c" ? {o a 1} "1" ? {::nsf::setter o a:integer} "::o::a" ? {::nsf::setter o ints:integer,1..*} "::o::ints" ? {::nsf::setter o o:object} "::o::o" ? {o info method handle ints} "::o::ints" ? {o info method definition ints} "::o public setter ints:integer,1..*" ? {o info method parameter ints} "ints:integer,1..*" ? {o info method args ints} "ints" ? {o info method handle o} "::o::o" ? {o info method definition o} "::o public setter o:object" ? {o info method parameter o} "o:object" ? {o info method args 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 ? {::nsf::setter o {d default}} {parameter "d" is not allowed to have default "default"} ? {::nsf::setter o -x} {invalid setter name "-x" (must not start with a dash or colon)} } ####################################################### # test for slot-optimizer ####################################################### Test parameter count 1000 Test case slot-optimizer { Class create C -attributes {a b:integer c:integer,multivalued} C create c1 ? {c1 a 1} 1 ? {c1 b 1} 1 ? {c1 c 1} 1 # before: 1st case: setter, 2&3: forward #slot-optimizer.001: 1.50 mms, c1 a 1 #slot-optimizer.002: 3.30 mms, c1 b 1 #slot-optimizer.003: 3.40 mms, c1 c 1 # # after: 1st, 2nd, 3rd case: setter #slot-optimizer.001: 1.50 mms, c1 a 1 #slot-optimizer.002: 1.50 mms, c1 b 1 #slot-optimizer.003: 1.60 mms, c1 c 1 } Test parameter count 10 Test case slot-nosetter { Class create C -attributes {a b:integer,nosetter {c:nosetter ""}} ? {C create c1 -a 1 -b 2} ::c1 ? {c1 info vars} "a b c" ? {c1 a 100} 100 ? {c1 b 101} {::c1: unable to dispatch method 'b'} ? {c1 c 102} {::c1: unable to dispatch method 'c'} } Test parameter count 1000 Test case check-arguments { Class create Foo { :public method noarg {} {return ""} :public method onearg {x} {return $x} :public method intarg {x:integer} {return $x} :public method intsarg {x:integer,1..*} {return $x} :public method boolarg {x:boolean} {return $x} :public method classarg {x:class} {return $x} :public method upperarg {x:upper} {return $x} :public method metaclassarg {x:metaclass} {return $x} :create f1 } ? {f1 noarg} "" ? {f1 onearg 1} 1 # built-in checker ? {f1 intarg 1} 1 ? {f1 intarg a} {expected integer but got "a" for parameter "x"} ? {f1 intsarg {10 11 12}} {10 11 12} ? {f1 intsarg {10 11 1a2}} {invalid value in "10 11 1a2": expected integer but got "1a2" for parameter "x"} ? {f1 boolarg 1} 1 ? {f1 boolarg a} {expected boolean but got "a" for parameter "x"} ? {f1 classarg ::Foo} ::Foo ? {f1 classarg f1} {expected class but got "f1" for parameter "x"} # tcl checker ? {f1 upperarg ABC} ABC ? {f1 upperarg abc} {expected upper but got "abc" for parameter "x"} # scripted checker ? {f1 metaclassarg ::nx::Class} ::nx::Class ? {f1 metaclassarg ::Foo} {expected metaclass but got "::Foo" for parameter "x"} } Test case slot-traces { ::nx::Object create o { :attribute a {set :defaultcmd { set _ 4 } } :attribute b {set :valuecmd { set _ 44 } } :attribute c {set :valuechangedcmd { ::nsf::setvar $obj $var 999 }} } ? {o a} 4 ? {o b} 44 ? {o c 5} 999 o copy o2 ? {o a} 4 ? {o b} 44 ? {o c 5} 999 ::nx::Class create C { :attribute a {set :defaultcmd { set _ 4 } } :attribute b {set :valuecmd { set _ 44 } } :attribute c {set :valuechangedcmd { ::nsf::setvar $obj $var 999 }} :create c1 } ? {c1 a} 4 ? {c1 b} 44 ? {c1 c 5} 999 c1 copy c2 ? {c2 a} 4 ? {c2 b} 44 ? {c2 c 5} 999 C copy D D create d1 ? {d1 a} 4 ? {d1 b} 44 ? {d1 c 5} 999 } ::nsf::configure checkarguments off Test case check-arguments-nocheck { Class create Foo { :public method noarg {} {return ""} :public method onearg {x} {return $x} :public method intarg {x:integer} {return $x} :public method intsarg {x:integer,1..*} {return $x} :public method boolarg {x:boolean} {return $x} :public method classarg {x:class} {return $x} :public method upperarg {x:upper} {return $x} :public method metaclassarg {x:metaclass} {return $x} :create f1 } ? {f1 noarg} "" ? {f1 onearg 1} 1 # built-in checker ? {f1 intarg 1} 1 ? {f1 intarg a} a ? {f1 intsarg {10 11 12}} {10 11 12} ? {f1 intsarg {10 11 1a2}} {10 11 1a2} ? {f1 boolarg 1} 1 ? {f1 boolarg a} a ? {f1 classarg ::Foo} ::Foo ? {f1 classarg f1} f1 # tcl checker ? {f1 upperarg ABC} ABC ? {f1 upperarg abc} abc # scripted checker ? {f1 metaclassarg ::nx::Class} ::nx::Class ? {f1 metaclassarg ::Foo} ::Foo } ## TODO regression test for type checking, parameter options (initcmd, ## substdefault, combinations with defaults, ...), etc. Test parameter count 100 Test case checktype { nx::Object create o { :public method f01 {} {::nsf::dispatch o ::nsf::methods::object::info::hastype ::nx::Object} :public method f02 {} {::nsf::dispatch o ::nsf::methods::object::info::hastype nx::Object} :public method f03 {} {::nsf::dispatch o ::nsf::methods::object::info::hastype Object} :public method f11 {} {::nsf::is object,type=::nx::Object o} :public method f12 {} {::nsf::is object,type=nx::Object o} :public method f13 {} {::nsf::is object,type=Object o} } ? {o f01} 1 ? {o f02} 1 ? {o f03} 1 ? {o f11} 1 ? {o f12} 1 ? {o f13} 1 } # # testing namespace resolution in type checkers # namespace eval foo { nx::Class create C { :create c1 :public method f21 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype Object} :public method f22 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype C} :public method f31 {} {::nsf::is object,type=Object c1} :public method f32 {} {::nsf::is object,type=C c1} } nx::Object create o { :public method f01 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype ::nx::Object} :public method f02 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype nx::Object} :public method f03 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype Object} :public method f04 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype foo::C} :public method f05 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype C} :public method f11 {} {::nsf::is object,type=::nx::Object c1} :public method f12 {} {::nsf::is object,type=nx::Object c1} :public method f13 {} {::nsf::is object,type=Object c1} :public method f14 {} {::nsf::is object,type=foo::C c1} :public method f15 {} {::nsf::is object,type=C c1} } ? {o f01} 1 ? {o f02} 1 ? {o f03} 1 ? {o f04} 1 ? {o f05} 1 ? {o f11} 1 ? {o f12} 1 ? {o f13} 1 ? {o f14} 1 ? {o f15} 1 ? {c1 f21} 1 ? {c1 f22} 1 ? {c1 f31} 1 ? {c1 f32} 1 } Test case check-arguments { Class create Foo { :method noarg {} {return ""} :method onearg {-x} {return $x} :method intarg {-x:integer} {return $x} :method intsarg {-x:integer,1..*} {return $x} :method boolarg {-x:boolean} {return $x} :method classarg {-x:class} {return $x} :method upperarg {-x:upper} {return $x} :method metaclassarg {-x:metaclass} {return $x} } ? {Foo info method parametersyntax noarg} "" ? {Foo info method parametersyntax onearg} "?-x value?" ? {Foo info method parametersyntax intarg} "?-x integer?" ? {Foo info method parametersyntax intsarg} "?-x integer ...?" ? {Foo info method parametersyntax boolarg} "?-x boolean?" ? {Foo info method parametersyntax classarg} "?-x class?" ? {Foo info method parametersyntax upperarg} "?-x upper?" ? {Foo info method parametersyntax metaclassarg} "?-x metaclass?" # return enumeration type ? {nx::Class info method parametersyntax "info mixinof"} \ "?-closure? ?-scope all|class|object? ?pattern?" } # # Check whether resetting via method "configure" changes values in the # initialzed object state. # Test case dont-reset-to-defaults { Class create C { :attribute {a 1} :create c1 } ? {c1 a} 1 # change the value from the default to a different value ? {c1 a 2} 2 ? {c1 a} 2 # call configure ... c1 configure # ... and check, it did not reset the value to the default ? {c1 a} 2 } Test case setter-under-coloncmd-and-interpvarresolver { # There are (at least) three forms of object-namespace alignment in # NSF: # 1. Same-named namespace (::omon) predates a same-named object # (::omon), the namespace is registered as per-object namespace with # the object upon object construction -> no NsColonVarResolver(), # InterpColonVarResolver() is responsible! # 2. an explicit per-object namespace creation using [:require # namespace] -> NsColonVarResolver() is put in place! # 3. Object get per-object members (fields, methods) -> # NsColonVarResolver() is put in place! # # The following test covers scenario 1: Called from within # NsfSetterMethod(), SetInstVar() verifies, whether there is a # per-object namespace (objPtr->nsPtr); if so, TCL_NAMESPACE_ONLY is # set ... in this object/ns alignment scenario, # InterpColonVarResolver() (!) serves the var resolution request. It # effectively forward-passes the resolution request when sensing # TCL_NAMESPACE_ONLY by signalling TCL_CONTINUE. This is a consequence # of handling the "compiled [variable] vs. AVOID_RESOLVERS" case # InterpColonVarResolver(). As in colon-prefixed calls to the setter # method (via ColonCmd()), the colon prefix is present in the # name-carrying Tcl_Obj used to in SetInstVar(). As we set an object # frame context, we effectively end up with a colon-prefixed object # variable :( Class create Omon ::nsf::setter Omon a1 namespace eval omon {} Omon create omon omon a1 "" ? {omon info vars a1} "a1" ? {omon info vars :a1} "" omon eval { :a1 "" ? [list [current] info vars a1] "a1" # Prior to the fix, [:info vars] would have returned ":a1" ? [list [current] info vars :a1] "" } } Test case req-param { ::nx::Class create C { :attribute y:required :attribute x:required :method init args {set ::_ $args} } set ::_ "" ? {C create c2 -y 1 -x} {Argument for parameter '-x' expected} ? {set ::_} "" ? {c2 x} {can't read "x": no such variable} ? {C create c3 -y 1 -x 0} "::c3" ? {set ::_} "" ? {c3 x} "0" } ::nsf::configure checkarguments on # # Test argument processing and namespace handling in nsf::procs # Test case nsf-proc { # # test inner namespace and handling of switches # nsf::proc ::nsf::mix {-per-object:switch -x:boolean} { return [namespace current]-${per-object}-[info exists x] } # # test handling of "-ad" flag # nsf::proc -ad ad_returnredirect { {-message {}} {-html:boolean} {-allow_complete_url:boolean} {-x:switch} target_url } { return [namespace current]-[lsort [info vars]]-$html_p-$allow_complete_url_p } # # test inner namespace and flag passing via -flag=$value notation # namespace eval ::ns1 { nsf::proc -ad foo {-s:boolean} {return [namespace current]-$s_p} nsf::proc bar {-s:switch} {return [namespace current]-[info exists s]} nsf::proc baz {-b:boolean arg} {return [namespace current]-[info exists b]-$arg} nsf::proc -ad pass0 {-s:boolean} {foo {*}[expr {$s_p ? "-s" : ""}]} nsf::proc -ad pass1 {-s:boolean} {foo -s=$s_p} } Test parameter count 1 ? {::nsf::mix} "::nsf-0-0" ? {::nsf::mix -per-object} "::nsf-1-0" ? {ad_returnredirect /url} "::-allow_complete_url_p html_p message target_url x-0-0" ? {ad_returnredirect -html /url} "::-allow_complete_url_p html_p message target_url x-1-0" ? {ad_returnredirect -html=0 /url} "::-allow_complete_url_p html_p message target_url x-0-0" ? {ad_returnredirect -html=a /url} {expected boolean but got "a" for parameter "-html"} ? {::ns1::foo} "::ns1-0" ? {::ns1::foo -s} "::ns1-1" ? {::ns1::foo -s=1} "::ns1-1" ? {::ns1::foo -s=0} "::ns1-0" ? {::ns1::foo -s -s=0} "::ns1-0" ? {::ns1::baz -b true -- -b} "::ns1-1--b" Test parameter count 1000 ? {::ns1::pass1} "::ns1-0" ? {::ns1::pass1 -s} "::ns1-1" ? {::ns1::pass0} "::ns1-0" ? {::ns1::pass0 -s} "::ns1-1" } # # Test argument processing and namespace handling in nsf::procs # Test case xotcl-list-notation { Test parameter count 1 package req XOTcl xotcl::Class create CC -parameter {package_id parameter_declaration user_id} # first, without list notation ? {CC create cc -package_id 123 -parameter_declaration o -user_id 4} "::cc" ? {cc package_id} 123 ? {cc parameter_declaration} o ? {cc user_id} 4 # new without list notation ? {CC create cc -package_id 234 [list -parameter_declaration oo] -user_id 456} ::cc ? {cc package_id} 234 ? {cc parameter_declaration} oo ? {cc user_id} 456 }