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