# -*- Tcl -*- package prefer latest package require XOTcl 2.0; namespace import -force ::xotcl::* package require nx::test nx::test configure -count 1000 # what's new: # - slots instances are manager objects for slot values # - generalization of slots to have different kind of domains and managers # - slots for objects and classes (slot parameter 'per-object' true|false, # when to used on a class object) # - works for mixins/filters/class/superclass (e.g ... superclass add ::M) # - defaultcmd and valuecmd # defaultcmd: is executed when the instance variable is read the first time # valuecmd: is executed whenever the instance variable is read # (implemented via trace; alternate approach for similar behavior # is to define per-object procs for get/assign, see e.g. slots for # class and superclass; slots require methods to be invoked, # not var references; # otoh, trace are somewhat more fragile and harder to debug) # default, defaultcmd and valuecmd are to be used mutually exclusively # - valuechangedcmd: executed after the change of an instance variable, # can be used e.g. for validation # # -gustaf neumann 21.Jan. 2006 package require nx::serializer ####################################################### set ::hu 0 proc T1 {var sub op} {c1 set $var t1} proc T2 {var sub op} {c1 set $var t2} Class C -slots { #Attribute create x -defaultcmd {set x 1} #Attribute create y -defaultcmd {incr ::hu} #Attribute create z -defaultcmd {my trace add variable z read T1} Attribute create x -trace default x object method value=default {obj property} { return 1 } Attribute create y -trace default y object method value=default {obj property} { incr ::hu } Attribute create z -trace default z object method value=default {obj property} { $obj trace add variable z read T1 } } C create c1 ? {c1 info vars x} "" ? {c1 x} "1" ? {c1 info vars x} "x" ? {c1 info vars y} "" ? {c1 y} 1 ? {c1 set x} 1 ? {set ::hu} 1 proc ?? {cmd expected {msg ""}} { #puts "??? $cmd" set r [uplevel $cmd] if {$msg eq ""} {set msg $cmd} if {$r ne $expected} { puts stderr "ERROR $msg returned '$r' ne '$expected'" error "FAILED $msg returned '$r' ne '$expected'" } else { puts stderr "OK $msg" } } Class D -slots { # Attribute create x -defaultcmd {set x 2} # Attribute create z -defaultcmd {my trace add variable z read T2} Attribute create x -trace default x object method value=default {obj property} { return 2 } Attribute create z -trace default z object method value=default {obj property} { $obj trace add variable z read T2 } ?? self ::D ?? {namespace current} ::D::slot } -superclass C D create c1 ? {c1 set x} 2 ? {c1 z} "" ? {c1 z} t2 ? {c1 y} 2 ? {set ::hu} 2 ####################################################### # # a small helper Object instproc slots cmds { if {![my isobject [self]::slot]} {Object create [self]::slot} namespace eval [self]::slot $cmds } ###################### # system slots ###################### Class M Class O -mixin M ? {O mixin} ::M ? {catch {Object o -mixin check1 M}} 1 ? {O mixin} ::M Class M2 O mixin add M2 ? {O mixin} {::M2 ::M} O mixin M2 ? {O mixin} ::M2 O mixin "" ? {O mixin} "" #O mixin set M ;# not sure, whether we should keep set here, or use assign or some better term O mixin assign M ;# new name ? {O mixin} ::M ? {O mixin ""} "" # with slots like class etc. we have to option to # a) rename the original command like in the following # b) provide a no-op value, such that we define only meta-data in the slot # c) define a low-level tcl command like setrelation (or extend it) to handle the setter # "class" is not multivalued, therefore we should not add (or remove) add/delete # from the set of subcommands... ? {::nx::RelationSlot info class} "::nx::MetaSlot" O o1 ? {o1 class} "::O" o1 class Object ? {o1 class} "::xotcl::Object" ? {o1 __object_configureparameter} "-mixin:mixinreg,alias,0..n -filter:filterreg,alias,0..n -class:class,alias args:alias,method=residualargs,args" ? {Object __object_configureparameter} "-instfilter:filterreg,alias,0..n -superclass:alias,0..n -instmixin:mixinreg,alias,0..n {-__default_metaclass ::xotcl::Class} {-__default_superclass ::xotcl::Object} -mixin:mixinreg,alias,0..n -filter:filterreg,alias,0..n -class:class,alias args:alias,method=residualargs,args" ? {o1 class add M} {class: expected a class but got "M ::xotcl::Object"} ? {O superclass} "::xotcl::Object" Class O2 -superclass O #? {O2 superclass O} "superclass 1" ? {O superclass} "::xotcl::Object" ::nx::ObjectParameterSlot public method slot {object name property} { switch $property { self {return [self]} domain {return [my domain]} } } #? {O superclass slot self} "::xotcl::Class::slot::superclass" ? {O ::nsf::methods::object::info::lookupslots superclass} "::xotcl::Class::slot::superclass" ? {::xotcl::Class::slot::superclass cget -domain} "::xotcl::Class" ? {O2 superclass} "::O" O2 superclass add M ? {O2 superclass} "::M ::O" O2 superclass delete ::O ? {O2 superclass} "::M" # # test "... info default ..." and "... info instdefault ..." # ::nx::test case info-default { ::xotcl::Class create ::Test ::Test proc m0 {-id:required {-flag:boolean true} -switch:switch x {y 1}} {return 0} ::Test instproc m1 {-id:required {-flag:boolean true} -switch:switch x {y 1}} {return 0} ? {::Test info default m0 y default0} 1 ? {info exists default0} 1 ? {::Test info default m0 x default1} 0 unset -nocomplain default0 default1 ? {::Test info instdefault m1 y default0} 1 ? {info exists default0} 1 ? {::Test info instdefault m1 x default1} 0 } # # The main difference between an Attribute and a Role is that it # references some other objects # ::xotcl::MetaSlot create Role -superclass Attribute -parameter {references} ::nx::test case info-slots-heritage { ::xotcl::Class create C -parameter {c1 c2} ::xotcl::Class create D -superclass C -parameter {c2 c3} ? {C info heritage} "::xotcl::Object" ? {D info heritage} "::C ::xotcl::Object" # xotcl info heritage should not see the mixins C instmixin [::xotcl::Class create M] ? {C info superclass -closure} "::xotcl::Object" ? {D info superclass -closure} "::C ::xotcl::Object" ? {D info heritage} "::C ::xotcl::Object" ? {C info slots} "::C::slot::c1 ::C::slot::c2" ? {D info slots} "::D::slot::c2 ::D::slot::c3" ? {D info slots -closure -source application} "::D::slot::c2 ::D::slot::c3 ::C::slot::c1" } ###################### # application classes ###################### Class Person -slots { Attribute create name Attribute create age -default 0 } Class Article -slots { Attribute create title Attribute create date } Class publishes -slots { Role create written_by -references Person -multiplicity 0..n Role create has_published -references Paper -multiplicity 0..n } Class Project -slots { Attribute create name Role create manager -references Person Role create member -references Person -multiplicity 0..n } puts [Person serialize] Person::slot::name configure -default "gustaf" ? {Person::slot::name cget -default} gustaf Person p1 -name neophytos ? {p1 name} neophytos ? {p1 age} 0 p1 age 123 ? {p1 age} 123 Object o1 o1 set i 0 ::nsf::method::alias o1 Incr -frame object ::incr ? {o1 incr i} 1 "method incr" ? {o1 Incr i} 1002 "aliased tcl incr" ? {o1 incr i} 2003 "method incr" ? {o1 Incr i} 3004 "aliased tcl incr" ::nsf::method::alias ::xotcl::Object Set -frame object ::set ? {o1 set i 1} 1 "method set" ? {o1 set i} 1 "method set" ? {o1 Set i 1} 1 "aliased tcl set" ? {o1 Set i} 1 "aliased tcl set" ::nsf::method::alias o1 Set -frame object ::set ? {o1 Set i 1} 1 "aliased object tcl set" ? {o1 Set i} 1 "aliased object tcl set" ::xotcl::Object instforward SSet -earlybinding -objscope ::set ? {o1 SSet i 1} 1 "forward earlybinding tcl set" ? {o1 SSet i} 1 "forward earlybinding tcl set" ? {::xotcl::Object info instforward -definition SSet} "-earlybinding -objscope ::set" o1 set z 100 #o1 forward z o1 [list %argclindex [list set set]] %proc #o1 proc get name {my set $name} o1 forward get -earlybinding ::nsf::var::set %self %1 ? {o1 info forward} get ? {o1 get z 101} 101 ? {o1 get z} "101" ? {o1 get z} 101 "get value via new parametercmd get" ? {o1 get z 124} 124 "set value via new parametercmd get" o1 forward zz -earlybinding ::nsf::var::set %self %proc ? {o1 zz 123} 123 ? {o1 zz} 123 ? {o1 zz} 123 "parametercmd forward earlybinding setinstvar" ? {o1 zz 124} 124 "parametercmd forward earlybinding setinstvar" o1 forward z2 -earlybinding -objscope ::set %proc ? {o1 z2 111} 111 "parametercmd forward earlybinding tcl set" ? {o1 z2} 111 "parametercmd forward earlybinding tcl set" o1 forward z3 -objscope ::set %proc ? {o1 z3 111} 111 "parametercmd forward tcl set" ? {o1 z3} 111 "parametercmd forward tcl set" o1 set y 11 o1 parametercmd y ? {o1 y} 11 "parametercmd" ? {o1 y 1} 1 "parametercmd" #Class C -parameter {a {b 10} {c "Hello World"}} #C copy V #puts [C serialize] #puts [V serialize] #C destroy #V v1 #puts [v1 b] # ::xotcl::Object instproc param arglist { # foreach arg $arglist { # puts "arg=$arg" # set l [llength $arg] # set name [lindex $arg 0] # if {![my isobject [self]::slot]} {::xotcl::Object create [self]::slot} # if {$l == 1} { # Attribute create [self]::slot::$name # } elseif {$l == 2} { # Attribute create [self]::slot::$name -default [lindex $arg 1] # } else { # set paramstring [string range $arg [expr {[string length $name]+1}] end] # #puts stderr "remaining arg = '$paramstring'" # if {[string match {[$\[]*} $paramstring]} { # #puts stderr "match, $cl set __defaults($name) $paramstring" # Attribute create [self]::slot::$name -default $paramstring # continue # } # } # } # } # maybe work directly on ::xotcl::Attribute would be nicer, when # ::xotcl::Attribute would be true alias for ::nx::VariableSlot ... #::nx::VariableSlot mixin delete ::nx::VariableSlot::Optimizer Class C1 -parameter {a {b 10} {c "Hello World"}} C1 c1 -a 1 ? {c1 a} 1 ? {c1 b} 10 ? {c1 c} "Hello World" ##### is short form of Class C2 -slots { Attribute create a Attribute create b -default 10 Attribute create c -default "Hello World" } C2 c2 -a 1 ? {c2 procsearch a} "::C2 instparametercmd a" ? {c2 a} 1 ? {c2 b} 10 ? {c2 c} "Hello World" ? {c2 a} 1 "new indirect parametercmd" ? {c2 a 1} 1 "new indirect parametercmd" #::nx::VariableSlot mixin add ::nx::VariableSlot::Optimizer Class C3 -slots { Attribute create a Attribute create b -default 10 Attribute create c -default "Hello World" } C3 c3 -a 1 ? {c3 procsearch a} "::C3 instparametercmd a" ? {c3 a} 1 ? {c3 b} 10 ? {c3 c} "Hello World" ? {c3 a} 1 "new indirect parametercmd optimized" ? {c3 a 1} 1 "new indirect parametercmd optimized" ####### nasty names Class create D -slots { Attribute create create -default 1 } D d1 ####### gargash 2 Class create A -parameter {{foo 1}} # or Class create A -slots { Attribute create foo -default 1 } A create a1 -foo 234 ;# calls default foo setter A instproc f1 {} {puts hu} A instforward f2 puts hu A create a0 #a0 f1 a0 proc f3 {} {puts hu} a0 forward f4 puts hu ? {a0 procsearch f1} "::A instproc f1" ? {a0 procsearch f2} "::A instforward f2" ? {a0 procsearch f3} "::a0 proc f3" ? {a0 procsearch f4} "::a0 forward f4" ? {a0 procsearch set} "::xotcl::Object instcmd set" ? {A::slot::foo info lookup method value=set} "::nsf::classes::xotcl::Attribute::value=set" # redefine setter for foo of class A #A slot foo method assign {domain var val} ... A::slot::foo public object method assign {domain var val} { # Do something with [self] that isn't valid before init #puts setter-[self proc] $domain set $var $val } a1 foo ;# calls default foo getter a1 foo 123 ;# calls overridden foosetter ? {a1 foo} 123 #puts [A serialize] ################### nx::test case req-param { ::xotcl::Class create C -parameter {y:required x:required} C instproc init args {set ::_ $args} set ::_ "" ? {C create c2 -y 1 -x} {value for parameter '-x' expected} ? {set ::_} "" ? {::nsf::is object c2} 0 ? {C create c3 -y 1 -x 0} "::c3" ? {set ::_} "" ? {c3 x} "0" } ################### # Application Slots # nx::test case app-slots Class Person -slots { Attribute create name Attribute create age -default 0 Attribute create projects -default {} -multiplicity 0..n -incremental true } Person p1 -name "Gustaf" ? {p1 name} Gustaf ? {p1 age} 0 ? {p1 projects} {} Class Project -slots { Attribute create name Attribute create description } Project project1 -name XOTcl -description "A highly flexible OO scripting language" p1 projects add ::project1 ? {p1 projects} ::project1 #p1 projects add some-other-value #? {p1 projects} "some-other-value ::project1" ::nx::ObjectParameterSlot method check { {-keep_old_value:boolean true} value predicate type obj var } { puts "+++ checking $value with $predicate ==> [expr $predicate]" if {![expr $predicate]} { if {[$obj exists __oldvalue($var)]} { $obj set $var [$obj set __oldvalue($var)] } else { $obj unset $var } error "$value is not of type $type" } if {$keep_old_value} {$obj set __oldvalue($var) $value} } ::nx::ObjectParameterSlot method checkall {values predicate type obj var} { foreach value $values { my check -keep_old_value false $value $predicate $type $obj $var } $obj set __oldvalue($var) $value } Person slots { Attribute create projects -default "" -multiplicity 0..n -incremental true -type ::Project Attribute create salary -type integer } Person p2 -name "Gustaf" p2 projects add ::project1 ? {p2 projects add ::o1} {expected object of type ::Project but got "::o1" for parameter "value"} p2 salary 100 ? {catch {p2 salary 100.9}} 1 ? {p2 salary} 100 p2 append salary 9 ? {p2 salary} 1009 # todo currently not checked #? {catch {p2 append salary b}} 1 ? {p2 salary} 1009 Person slots { Attribute create sex -type "sex" -convert true -proc 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 p3 -sex male ? {p3 sex} m Person method foo {s:sex,slot=::Person::slot::sex,convert} {return $s} ? {p3 foo male} "m" ? {p3 sex male} m ####################################################### # defaultcmd via slots ####################################################### nx::test case defaultcmd set ::hu 0 Class C -slots { # Attribute create x -defaultcmd {incr ::hu; set x 101} Attribute create x -trace default x object method value=default {obj property} { incr ::hu; return 101 } } C c1 ? {c1 info vars} "__initcmd" ? {c1 set x} 101 ? {c1 info vars} "x __initcmd" ? {set ::hu 1} 1 ####################################################### # nested contains ####################################################### nx::test case nested-contains Class Point -parameter {{x 100} {y 300}} Class Rectangle -parameter {color} Rectangle r0 -color pink -contains { Rectangle r1 -color red -contains { Point x1 -x 1 -y 2 Point x2 -x 1 -y 2 } Rectangle r2 -color green -contains { Point x1 Point x2 } } #? {r0 color} pink #? {r0 r1 color} red #? {r0 r1 x1 x} 1 #? {r0 r1 x2 y} 2 #? {r0 r2 color} green ? {r0 color} pink ? {r0::r1 color} red ? {r0::r1::x1 x} 1 ? {r0::r1::x2 y} 2 ? {r0::r2 color} green #puts [r0 serialize] ####################################################### # assign via slots ####################################################### nx::test case assign-via-slots Class create A -slots { Attribute create foo -default 1 -proc value=set {domain var value} { if {$value < 0 || $value > 99} { error "$value is not in the range of 0 .. 99" } $domain set $var $value } } A create a1 ? {a1 foo 10} 10 ? {a1 foo 20} 20 ? {a1 foo} 20 ? {a1 foo -1} "-1 is not in the range of 0 .. 99" ? {catch {a1 foo -1}} 1 ? {a1 foo 100} "100 is not in the range of 0 .. 99" ? {a1 foo 99} 99 set x [Object new -set x 1 -contains { Object new -set x 1.1 Object new -set x 1.2 -contains { Object new -set x 1.2.1 Object new -set x 1.2.2 -contains { Object new -set x 1.2.2.1 } Object new -set x 1.2.3 } Object new -set x 1.3 }] ? {llength [$x info children]} 3 ? {llength [[lindex [lsort [$x info children]] 0] info children]} 0 ? {llength [[lindex [lsort [$x info children]] 1] info children]} 3 ? {llength [[lindex [lsort [$x info children]] 2] info children]} 0 # # test case (bug) posted by Neil Hampton # Class Fred -slots { #Attribute create a -defaultcmd { set _ 4 } Attribute create a -trace default a object method value=default {obj property} { return 4 } } ? {Fred x} ::x ? {x a 4} 4 x move y ? {y a} 4 ::nx::test case slots-compat # # Some tests covering the backward compatibility of NX/XOTcl2 hybrid # slots to the XOTcl1 slot API (as extracted from the XOTcl language # reference) # # # 1) old-style Attribute creation # Class Window -slots { Attribute scrollbar; # old style Attribute create title; # new style } ? {lsort [Window info slots]} "::Window::slot::scrollbar ::Window::slot::title" # # 2) Dropped/missing slot attributes: multivalued # Class Person -slots { Attribute name Attribute salary -default 0 Attribute projects -default {} -multivalued true } ? {lsort [Person info slots]} "::Person::slot::name ::Person::slot::projects ::Person::slot::salary" ? {Person::slot::name multivalued get} 0 ? {Person::slot::salary multivalued get} 0 ? {Person::slot::projects multivalued get} 1 Person p2 -name "John Doe" ? {p2 name} "John Doe" ? {p2 salary} "0" ? {p2 projects} [list] Project compatPrj -name XOTclCompat p2 projects add ::compatPrj p2 projects add some-other-value ? {lsort [p2 projects]} "::compatPrj some-other-value" p2 projects delete some-other-value ? {lsort [p2 projects]} "::compatPrj" ? {catch {p2 name add BOOM!}} 1 ? {p2 name} "John Doe" # # 3) -proc inline statements upon Attribute creation # (as found in the tutorial) # Class create AA -slots { Attribute foo -default 1 -proc value=set {domain var value} { if {$value < 0 || $value > 99} { error "$value is not in the range of 0 .. 99" } $domain set $var $value } } AA create aa1 ? {aa1 foo 10} 10 ? {aa1 foo} 10 ? {catch {aa1 foo -1}} 1 nx::test case nx-serialize-debug-deprecated { ::xotcl::Object create o o proc ofoo {} {return 1} o proc obar {} {return 1} ? {::nsf::method::property o ofoo deprecated} 0 ? {::nsf::method::property o ofoo debug} 0 ? {::nsf::method::property o obar deprecated} 0 ? {::nsf::method::property o obar debug} 0 ::nsf::method::property o ofoo deprecated 1 ::nsf::method::property o obar debug 1 ? {::nsf::method::property o ofoo deprecated} 1 ? {::nsf::method::property o ofoo debug} 0 ? {::nsf::method::property o obar deprecated} 0 ? {::nsf::method::property o obar debug} 1 set script [o serialize] o destroy ? {::nsf::object::exists ::o} 0 eval $script ? {::nsf::method::property o ofoo deprecated} 1 ? {::nsf::method::property o ofoo debug} 0 ? {::nsf::method::property o obar deprecated} 0 ? {::nsf::method::property o obar debug} 1 } nx::test case nx-returns+serialize { ::xotcl::Class create Context ? {Context instproc default_form_loader {arg} -returns integer { return $arg }} "::nsf::classes::Context::default_form_loader" Context create c ? {c default_form_loader 0} 0 ? {c default_form_loader ""} {expected integer but got "" as return value} set ::string [Context serialize] c destroy Context destroy ? {eval $::string} "::nsf::classes::Context::default_form_loader" Context create c ? {c default_form_loader 0} 0 ? {c default_form_loader ""} {expected integer but got "" as return value} } # # Local variables: # mode: tcl # tcl-indent-level: 2 # indent-tabs-mode: nil # End: