# -*- 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: