# -*- Tcl -*- # # Basic tests of the object system, should not require Class Test, # since even class Test might not work at that time. # 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\n'$r' ne\n'$expected'" } else { puts stderr "OK $msg" } } package req nsf if {![string first [nsf::pkgconfig get version] [nsf::pkgconfig get patchLevel]]} { puts stderr "loaded :nsf::version $:nsf::version, ::nsf::patchLevel $::nsf::patchLevel" puts stderr "available versions of nsf: [package versions nsf]" } ? {string first [nsf::pkgconfig get version] [nsf::pkgconfig get patchLevel]} 0 package require nx ::nsf::configure dtrace on ? {::nsf::configure objectsystems} {{::nx::Object ::nx::Class {-class.alloc {__alloc ::nsf::methods::class::alloc 1} -class.create create -class.dealloc {__dealloc ::nsf::methods::class::dealloc 1} -class.configureparameter __class_configureparameter -class.recreate {__recreate ::nsf::methods::class::recreate 1} -object.configure __configure -object.configureparameter __object_configureparameter -object.defaultmethod {defaultmethod ::nsf::methods::object::defaultmethod} -object.destroy destroy -object.init {init ::nsf::methods::object::init} -object.move move -object.unknown unknown}}} ? {::nsf::object::exists nx::Object} 1 ? {::nsf::object::property nx::Object initialized} 1 ? {::nsf::is class nx::Object} 1 ? {::nsf::is metaclass nx::Object} 0 ? {nx::Object info superclasses} "" ? {nx::Object info class} ::nx::Class ? {nx::Object info baseclass} ::nx::Object ? {nx::Object info baseclass} [lindex [::nx::Object info precedence] end] ? {::nsf::object::exists nx::Class} 1 ? {::nsf::is class nx::Class} 1 ? {::nsf::is metaclass nx::Class} 1 ? {nx::Class info superclasses} ::nx::Object ? {nx::Class info class} ::nx::Class ? {nx::Class info baseclass} ::nx::Object ? {nx::Class info baseclass} [lindex [::nx::Class info precedence] end] # # Minimal argument passing tests for early problem detection # nsf::proc p0 {arg} {return [list $arg]} nsf::proc p1 {arg:optional} {return [list [info exists arg]]} nsf::proc p2 {arg args} {return [list $arg $args]} nsf::proc p3 {arg:optional args} {return [list [info exists arg] $args]} nsf::proc p4 {-x args} {return [list [info exists x] $args]} nsf::proc p5 {-x arg:optional -y args} {return [list [info exists x] [info exists y] [info exists arg] $args]} ? {p0 a} a ? {p1 a} 1 ? {p1} 0 ? {p2 a b c} {a {b c}} ? {p2 a} {a {}} ? {p2 a b} {a b} ? {p3 a b} {1 b} ? {p3 a b c} {1 {b c}} ? {p3 a} {1 {}} ? {p3} {0 {}} ? {p4} {0 {}} ? {p4 -x 1} {1 {}} ? {p4 -x 1 2} {1 2} ? {p4 -- -x 1 2} {0 {-x 1 2}} ? {p4 --} {0 {}} ? {p4 -- --} {0 --} ? {p4 -y --} {0 {-y --}} ;# no -y parameter, so pushed into args ? {p5} {0 0 0 {}} ? {p5 -x 1} {1 0 0 {}} ? {p5 a} {0 0 1 {}} ? {p5 -y 1} {0 0 1 1} ;# "-y" is passed into arg, "1" into args ? {p5 -y 1 2} {0 0 1 {1 2}} ;# "-y" is passed into arg, "1 2" into args ? {p5 -x 1 2} {1 0 1 {}} ;# "2" is passed into arg, "1 2" into args ? {p5 -y --} {0 0 1 {}} ;# "--" is value of "y" # # Create objects and test its properties # nx::Object create o ? {::nsf::object::exists nx::Object} 1 ? {::nsf::is class o} 0 ? {::nsf::is metaclass o} 0 ? {o info class} ::nx::Object ? {o info baseclass} ::nx::Object ? {o info baseclass} [lindex [o info precedence] end] ? {nx::Object info instances o} ::o ? {nx::Object info instances ::o} ::o o destroy ? {nsf::object::exists ::o} 0 ? {nsf::object::exists o} 0 nx::Object create o2 { ? {::nsf::object::exists ::o2} 1 ? {::nsf::object::property ::o2 initialized} 0 } ? {::nsf::object::property ::o2 initialized} 1 nx::Class create C0 ? {::nsf::is class C0} 1 ? {::nsf::is metaclass C0} 0 ? {C0 info superclasses} ::nx::Object ? {C0 info class} ::nx::Class #? {lsort [Class info vars]} "__default_metaclass __default_superclass" nx::Class create M -superclass ::nx::Class ? {::nsf::object::exists M} 1 ? {::nsf::is class M} 1 ? {::nsf::is metaclass M} 1 ? {M info superclasses} ::nx::Class ? {M info class} ::nx::Class ? {M info baseclass} ::nx::Object ? {M info baseclass} [lindex [M info precedence] end] M create C ? {::nsf::object::exists C} 1 ? {::nsf::is class C} 1 ? {::nsf::is metaclass C} 0 ? {C info superclasses} ::nx::Object ? {C info class} ::M C create c1 ? {::nsf::object::exists c1} 1 ? {::nsf::is class c1} 0 ? {::nsf::is metaclass c1} 0 ? {c1 info class} ::C nx::Class create M2 -superclass M ? {::nsf::object::exists M2} 1 ? {::nsf::is class M2} 1 ? {::nsf::is metaclass M2} 1 ? {M2 info superclasses} ::M ? {M2 info class} ::nx::Class M2 create m2 ? {m2 info superclasses} ::nx::Object ? {m2 info class} ::M2 # destroy meta-class M, reclass meta-class instances to the base # meta-class and set subclass of M to the root meta-class M destroy ? {::nsf::object::exists C} 1 ? {::nsf::is class C} 1 ? {::nsf::is metaclass C} 0 ? {C info superclasses} ::nx::Object ? {C info class} ::nx::Class ? {::nsf::is metaclass M2} 1 ? {M2 info superclasses} ::nx::Class ? {m2 info superclasses} ::nx::Object ? {m2 info class} ::M2 # destroy class M, reclass class instances to the base class C destroy ? {::nsf::object::exists C} 0 ? {::nsf::object::exists ::C} 0 ? {::nsf::object::exists c1} 1 ? {::nsf::is object c1} 1 ? {::nsf::is class c1} 0 ? {::nsf::is metaclass c1} 0 ? {c1 info class} ::nx::Object # # tests for dispatching methods # nx::Object create o o public object method foo {} {return foo} o public object method bar1 {} {return bar1-[:foo]} o public object method bar2 {} {return bar2-[: foo]} o public object method bar4 {} {return bar4-[[self] foo]} o public object method bar5 {} {return [self]::bar5} o public object method bar6 {} {return [:]::bar6} o public object method bar7 {} {return bar7-[lsort [: -system info object methods bar7]]} # dispatch without colon names ? {o foo} foo "simple method dispatch" ? {o bar1} bar1-foo "colon-methodname dispatch" ? {o bar2} bar2-foo "colon cmd dispatch" #? {o bar3} bar3-foo "my dispatch" ? {o bar4} bar4-foo "self dispatch" ? {o bar5} ::o::bar5 "self cmd" ? {o bar6} ::o::bar6 "colon cmd" ? {o bar7} bar7-bar7 "colon cmd dispatch args" o destroy # basic attributes tests nx::Class create C { :property {x 1} :property {y 2} } ? {::nsf::object::exists C} 1 ? {::nsf::object::exists C::slot} 1 ? {C info children} ::C::slot #? {C::slot info vars} __parameter #? {C info attributes} {{x 1} {y 2}} ? {C info lookup parameters create x} {{-x 1}} ? {C info lookup parameters create y} {{-y 2}} ? {C copy X} ::X ? {::nsf::object::exists X} 1 ? {X info vars} "" ? {C info vars} "" ? {::nsf::object::exists X::slot} 1 ? {set c1 [C new]} "::nsf::__#1" ? {nsf::object::property $c1 autonamed} 1 ? {$c1 copy c2} "::c2" ? {nsf::object::property c2 autonamed} 0 # copy without new name ? {c2 copy} ::nsf::__#4 ? {set C [C copy]} ::nsf::__#6 ? {::nsf::object::exists ${C}::slot} 1 #? {X::slot info vars} __parameter ? {X info lookup parameters create ?} {{-x 1} {-y 2}} ? {X info lookup parameters create x} {{-x 1}} ? {X info lookup parameters create y} {{-y 2}} #? {X info properties} {{x 1} {y 2}} #? {X info properties -closure *a*} {volatile:alias,noarg class:class,alias,method=::nsf::methods::object::class} # actually, we want c1 to test below the recreation of c1 in another # object system ? {C create c1} ::c1 ? {C create c2 {:object method foo {} {;}}} ::c2 # # check low-level method creation on classes, and check C-level # "-flag=value" handling # nsf::method::create ::C m1 {} {;} ? {lsort [::C ::nsf::methods::class::info::methods]} {m1} nsf::method::create ::C -per-object=false m2 {} {;} ? {lsort [::C ::nsf::methods::class::info::methods]} {m1 m2} nsf::method::create ::C -per-object=true m3 {} {;} ? {lsort [::C ::nsf::methods::object::info::methods]} {m3} # # tests for the dispatch command # nx::Object create o o object method foo {} {return goo} o object method bar {x} {return goo-$x} # dispatch without colon names ::nsf::dispatch o eval set :x 1 ? {o info vars} x "simple dispatch has set variable x" ? {::nx::var set o x} 1 "simple dispatch has set variable x to 1" ? {::nsf::dispatch o foo} "goo" "simple dispatch with one arg works" ? {::nsf::dispatch o bar 1} "goo-1" "simple dispatch with two args works" o destroy # dispatch with colon names nx::Object create o {set :x 1} ::nsf::dispatch ::o ::incr x ? {o eval {set :x}} 1 "cmd dispatch without -frame object did not modify the instance variable" ::nsf::directdispatch ::o -frame object ::incr x ? {o eval {set :x}} 2 "cmd dispatch -frame object modifies the instance variable" ? {catch {::nsf::dispatch ::o -frame object ::xxx x}} 1 "cmd dispatch with unknown command" o destroy nx::Object create o { :public object method foo {} { foreach var [list x1 y1 x2 y2 x3 y3] { lappend results $var [info exists :$var] } return $results } } ::nsf::directdispatch o ::eval {set x1 1; set :y1 1} ::nsf::directdispatch o -frame method ::eval {set x2 1; set :y2 1} ::nsf::directdispatch o -frame object ::eval {set x3 1; set :y3 1} ? {o foo} "x1 0 y1 0 x2 0 y2 1 x3 1 y3 1" o destroy # # Create objects via tcl ensembles # namespace eval k { nx::Class create s { :property j :method init {} {set :j} ;# the variable should be set } namespace export s namespace ensemble create } ? {k s create o -j X} ::o ::o destroy puts stderr ===MINI-OBJECTSYSTEM # test object system # create a minimal object system without internally dipatched methods ::nsf::objectsystem::create ::object ::class ? {::nsf::object::exists ::object} 1 ? {::nsf::is class ::object} 1 ? {::nsf::is metaclass ::object} 0 ? {::nsf::relation::get ::object class} ::class ? {::nsf::relation::get ::object superclass} "" ? {::nsf::object::exists ::class} 1 ? {::nsf::is class ::class} 1 ? {::nsf::is metaclass ::class} 1 ? {::nsf::relation::get ::class class} ::class ? {::nsf::relation::get ::class superclass} ::object # define non-standard methos to create/destroy objects and classes ::nsf::method::alias ::class + ::nsf::methods::class::create ::nsf::method::alias ::object - ::nsf::methods::object::destroy # create a class named C ::class + C ? {::nsf::object::exists ::C} 1 ? {::nsf::is class ::C} 1 ? {::nsf::is metaclass ::C} 0 ? {::nsf::relation::get ::C class} ::class ? {::nsf::relation::get ::C superclass} ::object # create an instance of C C + c1 ? {::nsf::object::exists ::c1} 1 ? {::nsf::is class ::c1} 0 ? {::nsf::is metaclass ::c1} 0 ? {::nsf::relation::get ::c1 class} ::C # destroy instance c1 - ? {::nsf::object::exists ::c1} 0 ? {::nsf::is class ::C} 1 # recreate an nx object with a namespace C + c2 # destroy class C - ? {::nsf::object::exists ::C} 0 ::nx::Class create ::C ? {catch {::C info has type ::UNKNOWN}} 1 ? {catch {::C info has type ::xyz::Bar}} 1 #? {catch {::nsf::is type ::CCCC ::nx::Object}} 1 ::C destroy # # Test protection against (most likely unintended) deletion of base # classes. # ? {catch {nx::Object destroy}} 1 ? {::nsf::object::exists nx::Object} 1 ? {catch {nx::Object create nx::Object}} 1 ? {::nsf::object::exists nx::Object} 1 ? {catch {nx::Object create nx::Class}} 1 ? {::nsf::object::exists nx::Class} 1 ? {catch {nx::Class create nx::Object}} 1 ? {catch {nx::Class create nx::Class}} 1 ? {catch {rename nx::Object ""}} 1 ? {::nsf::object::exists nx::Object} 1 ? {catch {rename nx::Object ""}} 1 ? {::nsf::object::exists nx::Object} 1 ? {catch {rename nx::Class ""}} 1 ? {::nsf::object::exists nx::Class} 1 # # Test overwriting of procs/methods # proc foo {} {;} # # Don't allow object to overwrite pre-existing proc/cmd, # which is not an object. # ? {catch {nx::Object create foo}} 1 rename foo "" nx::Object create foo { :object method bar {} {;} # # Don't allow subobject to overwrite object specific method # ? {catch {nx::Object create [self]::bar}} 1 } nx::Object create foo { nx::Object create [self]::bar # # Don't allow child-object to be overwritten by object specific cmd # ? {catch {:object forward bar somethingelse}} 1 ? {nsf::object::exists [self]::bar} 1 # # Don't allow child-object to be overwritten by object specific # scripted method # ? {catch {:object method bar {} {;}}} 1 ? {nsf::object::exists [self]::bar} 1 } foo destroy # # Test instances of diamond class structure. # # Leave class structure around until exit to test handling of # potentially duplicated entries during final cleanup # nx::Class create A nx::Class create B1 -superclass A nx::Class create B2 -superclass A nx::Class create C -superclass {B1 B2} ? {C create c1} ::c1 ? {A info instances -closure} ::c1 ::nsf::configure keepcmds 1 ::nx::Object create o {set :x 1} ? {o info vars} "x __cmd" ? {o eval {array get :__cmd}} "__initblock {set :x 1}" ::nsf::configure dtrace off puts stderr "===EXIT [info script]" # # Local variables: # mode: tcl # tcl-indent-level: 2 # indent-tabs-mode: nil # End: