# $Id: slottest.xotcl,v 1.5 2007/08/14 16:38:27 neumann Exp $
package require XOTcl 1
namespace import -force xotcl::*
package require xotcl::test 1

proc ? {cmd expected} {
  set t [Test new -cmd $cmd -count 100]
  $t expected $expected 
  $t run
}

proc t {cmd expected {txt ""}} {
  set t [Test new -cmd $cmd -msg $txt]
  $t expected $expected 
  $t run
}

# 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)
#   - initcmd and valuecmd 
#     initcmd: 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, initcmd 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 xotcl::serializer 1

#proc ? {cmd expected} {
#   set r [eval $cmd]		       
#   if {$r ne $expected} {error "$cmd returned '$r' ne '$expected'"}
#}

# proc t {cmd {txt ""}} {
#   set n 1000
#   #set ms [lindex [time [list time $cmd $n] 10] 0]
#   set ms [lindex [time [list time $cmd $n] 5] 0]
#   puts "[format %7.4f [expr {$ms*1.0/$n}]]ms for [format %-30s $cmd] ($txt)"
# }
#######################################################
# testing __initcmds
set ::hu 0
proc T1 {var sub op} {c1 set $var t1}
proc T2 {var sub op} {c1 set $var t2}
Class C -array set __initcmds {
  x {set x 1} 
  y {incr ::hu} 
  z {my trace add variable z read T1}}
C create c1
? {c1 info vars x} x
? {c1 info vars y} ""
? {c1 set x} 1
? {set ::hu} 1

Class D -array set __initcmds {
  x {set x 2} 
  z {my trace add variable z read T2}} -superclass C
D create c1
? {c1 set x} 2
? {c1 set z} t2
? {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
? {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} ::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...
? {::xotcl::InfoSlot class} "::xotcl::MetaSlot"
O o1
? {o1 class} "::O"
o1 class Object
? {o1 class} "::xotcl::Object"
? {catch {o1 class add M}} 1


? {O superclass} "::xotcl::Object"
Class O2 -superclass O

#t {O2 superclass O} "superclass 1"
? {O superclass} "::xotcl::Object"

::xotcl::Slot instproc slot {object name property} {
  switch $property {
    self {return [self]}
    domain {return [my domain]}
  }
}

? {O superclass slot self} "::xotcl::Class::slot::superclass"
? {O superclass slot domain} "::xotcl::Class"


? {O2 superclass} "::O"
O2 superclass add M
? {O2 superclass} "::M ::O"
O2 superclass delete ::O
? {O2 superclass} "::M"


# the main difference between an Attribute and a Role is that 
# it references some other objects
#Class Attribute -superclass ::xotcl::Slot
Class Role -superclass Attribute -parameter {references}

######################
# application classes
######################
Class Person -slots {
  Attribute name
  Attribute age -default 0
}

Class Article -slots {
  Attribute title
  Attribute date
}

Class publishes -slots {
  Role written_by -references Person -multivalued true
  Role has_published -references Paper -multivalued true
}

Class Project -slots {
  Attribute name
  Role manager -references Person
  Role member -references Person -multivalued true
}

puts [Person serialize]
Person slot name default "gustaf"
? {Person slot name default} gustaf
Person p1 -name neophytos
? {p1 name} neophytos
? {p1 age} 0
p1 age 123
? {p1 age} 123


Object o1
o1 set i 0
::xotcl::alias o1 Incr -objscope ::incr
t {o1 incr i} 1 "method incr"
t {o1 Incr i} 1002 "aliased tcl incr"
t {o1 incr i} 2003 "method incr"
t {o1 Incr i} 3004 "aliased tcl incr"

::xotcl::alias ::xotcl::Object Set -objscope ::set
t {o1 set i 1} 1 "method set"
t {o1 set i} 1 "method set"
t {o1 Set i 1} 1 "aliased tcl set"
t {o1 Set i} 1 "aliased tcl set"
::xotcl::alias o1 Set -objscope ::set
t {o1 Set i 1} 1 "aliased object tcl set"
t {o1 Set i} 1 "aliased object tcl set"
::xotcl::Object instforward SSet -earlybinding -objscope ::set
t {o1 SSet i 1} 1 "forward earlybinding tcl set"
t {o1 SSet i} 1 "forward earlybinding tcl set"
#exit

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 ::xotcl::setinstvar %self %1
? {o1 get z 101} 101
? {o1 get z} "101"

t {o1 get z} 101 "get value via new parametercmd get"
t {o1 get z 124} 124 "set value via new parametercmd get"


o1 forward zz -earlybinding ::xotcl::setinstvar %self %proc
? {o1 zz 123} 123
? {o1 zz} 123

t {o1 zz} 123 "parametercmd forward earlybinding setinstvar"
t {o1 zz 124} 124 "parametercmd forward earlybinding setinstvar"

o1 forward z2 -earlybinding -objscope ::set %proc
t {o1 z2 111} 111 "parametercmd forward earlybinding tcl set"
t {o1 z2} 111 "parametercmd forward earlybinding tcl set"

o1 forward z3 -objscope ::set %proc
t {o1 z3 111} 111 "parametercmd forward tcl set"
t {o1 z3} 111 "parametercmd forward tcl set"

o1 set y 11
o1 parametercmd y
t {o1 y} 11 "parametercmd"
t {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
#       }
#     }
#   }
# }


::xotcl::Slot instmixin delete ::xotcl::Slot::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 a 
  Attribute b -default 10
  Attribute c -default "Hello World"
}
C2 c2 -a 1
? {c2 procsearch a} "::C2 instforward a"
? {c2 a} 1
? {c2 b} 10
? {c2 c} "Hello World"


t {c2 a} 1 "new indirect parametercmd"
t {c2 a 1} 1 "new indirect parametercmd"

::xotcl::Slot instmixin add ::xotcl::Slot::Optimizer
Class C3 -slots {
  Attribute a 
  Attribute b -default 10
  Attribute c -default "Hello World"
}
C3 c3 -a 1
? {c3 procsearch a} "::C3 instparametercmd a"
? {c3 a} 1
? {c3 b} 10
? {c3 c} "Hello World"

t {c3 a} 1 "new indirect parametercmd optimized"
t {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 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 procsearch assign} "::xotcl::Slot instcmd assign"

# redefine setter for foo of class A
A slot foo proc assign {domain var val} {
  # Do something with [self] that isn't valid pre-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]

###################
# Application Slots
#

Class Person -slots {
  Attribute name
  Attribute age -default 0
  Attribute projects -default {} -multivalued true
}

Person p1 -name "Gustaf"
? {p1 name} Gustaf
? {p1 age} 0
? {p1 projects} {}

Class Project -slots {
  Attribute name 
  Attribute description
  Attribute manager
  Attribute member -multivalued 1
}
  
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"

::xotcl::Slot instproc 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}
}

::xotcl::Slot instproc 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 projects -default "" -multivalued true -type ::Project
  Attribute salary -type integer
}

Person p2 -name "Gustaf"
p2 projects add ::project1
? {catch {p2 projects add ::o1}} 1
p2 salary 100
? {catch {p2 salary 100.9}} 1
? {p2 salary} 100
p2 append salary 9
? {p2 salary} 1009
? {catch {p2 append salary b}} 1
? {p2 salary} 1009

Person slots {
  Attribute sex -type "my sex" -proc sex {value} {
    switch -glob $value {
      m* {my uplevel {$obj set $var m}; return 1}
      f* {my uplevel {$obj set $var f}; return 1}
      default {return 0}
    }
  }
}
Person p3 -sex male
? {p3 sex} m

set ::hu 0
Class C -slots {
  Attribute x -initcmd {incr ::hu; set x 101}
}
C c1
? {c1 info vars} ""
? {c1 set x} 101
? {c1 info vars} "x"
? {set ::hu 1} 1


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
#puts [r0 serialize]


#####
Class create A -slots {
  Attribute foo -default 1 -proc assign { 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
? {catch {a1 foo -1}} 1
? {catch {a1 foo 100}} 1
? {catch {a1 foo 99}} 0

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

# / / / / / / / / / / / / / / / / / / / / / / /
# Tests specific to per-object attribute slots
#

Class create C -slots {
  Attribute foo \
      -per-object true \
      -default 1
}

C create c

? {C procsearch foo} "::C parametercmd foo"
? {c procsearch foo} ""
? {C slot foo procsearch assign} "::xotcl::Slot instcmd assign"
? {C exists foo} 1
? {C set foo} 1
t {C foo} 1 "retrieves default value"
C foo 123
t {C foo} 123 "custom defined value"

C destroy

#
# basics (without default)
#

Class create C -slots {
  Attribute bar \
      -per-object true
}

C create c

? {C procsearch bar} "::C parametercmd bar"
? {c procsearch bar} ""
? {C slot bar procsearch assign} "::xotcl::Slot instcmd assign"
? {C exists bar} 0
? {C bar 1} 1
? {C bar} 1
? {c exists bar} 0

C destroy; c destroy

#
# basics (with default)
#

Class create C -slots {
  Attribute foo \
      -per-object true \
      -default 1
}

C create c

? {C procsearch foo} "::C parametercmd foo"
? {c procsearch foo} ""
? {C slot foo procsearch assign} "::xotcl::Slot instcmd assign"
? {C exists foo} 1
? {C set foo} 1
t {C foo} 1 "retrieves default value"
C foo 123
t {C foo} 123 "custom defined value"

# default is to be skipped when variable is already
# initialised

C set bar x
C slots {
  Attribute bar \
      -per-object true \
      -default y
}

? {C exists bar} 1
? {C bar} x

C destroy; c destroy

#
# trace-based hooks for per-object attributes
#

# a. initcmd
set ::__verify 0
Class C -slots {
  Attribute bar \
      -per-object true \
      -initcmd {incr ::__verify; set _ 101}
}

C create c

? {C exists bar} 1
? {set ::__verify} 1
? {C bar} 101
? {C exists bar} 1
? {set ::__verify} 1

# b. valuecmd

C slots {
  Attribute bar2 \
      -per-object true \
      -valuecmd {
	set ::__verify 2; set _ 101
      }
}

? {C exists bar2} 1
? {set ::__verify} 2
? {C bar2} 101
? {set ::__verify} 2
? {C bar2 202} 202

# c. valuechangedcmd
C slots {
  Attribute bar3 \
      -per-object true \
      -valuechangedcmd {
	set ::__verify 3; $obj set $var 909
      }
}

? {C exists bar3} 0
? {set ::__verify} 2
? {C bar3 101} 909
? {set ::__verify} 3
? {C bar3 102} 909

C destroy; c destroy

#exit

#puts [Person array get __defaults]
#puts [Person serialize]
#puts [Serializer all]
#eval [Serializer all]

? {p2 salary} 1009
? {catch {p2 append salary b}} 1
? {p2 salary} 1009
#p2 projects add ::o1

p1 set x 0
t {p1 set x} 0 "get instvar value via set"
t {p1 set x 1} 1 "set instvar value via set"


Object o1
proc f {x} {return $x}
o1 forward myf -earlybinding f
? {o1 myf abc} abc

rename f ""
proc f {x} {return 11}
? {o1 myf abc} 11

Object o2
o2 proc f {x} {expr {$x*2}}
o1 forward myf -earlybinding o2 f

? {o1 myf 100} 200

o1 set x 42
o1 forward x -earlybinding ::xotcl::setinstvar %self %proc
? [list o1 x] 42
? [list o1 x 41] 41
t {o1 x} 41 "get parametercmd via forward (earlybinding)"
t {o1 x 41} 41 "set parametercmd via forward (earlybinding)"

#obj forward Mixin -default {getter setter} mixin %1  %self
o1 forward z -default {getter setter} %self

o1 forward myfset -objscope set
o1 myfset y 102
? {o1 myfset y} 102

t {o1 myfset y} 102 "get instvar value via forward"
t {o1 myfset y 122} 122 "set instvar value via forward"

o1 forward myfdset -earlybinding -objscope set
o1 myfdset y 103
? {o1 myfdset y} 103

t {o1 myfdset y} 103 "get instvar value via forward -earlybinding"
t {o1 myfdset y 123} 123 "set instvar value via forward -earlybinding"

::xotcl::alias o1 myset -objscope ::set
o1 myset x 101
? {o1 myset x} 101

t {o1 myset x} 101 "get instvar value via set alias"
t {o1 myset x 123} 123 "set instvar value via set alias"

Class Fred -slots { Attribute create a -initcmd { set _ 4 } }
? {Fred x} ::x
? {x a 4} 4
x move y
? {y a} 4

exit

# t {p1 age} 0 "slot read"
# Class P -parameter {age {s -setter sets}}
# P instproc sets {var value} {
#   my set $var $value
# }
# P create p2 -age 345 -s 567

# t {p2 age} "parametercmd read"
# t {::xotcl::setinstvar p2 age} "via setinstvar"
# t {p2 s} "parameter read with setter"


::xotcl::Attribute create Project::slot::fullbudget \
    -initcmd {puts stderr init-on-[self];my set __x 100} \
    -valuechangedcmd {
      puts "budget is now [my set fullbudget]" 
      my set __x [my set fullbudget] 
    }

::xotcl::Attribute create Project::slot::currentbudget -valuecmd {puts stderr change-on-[self];my incr __x -1}

Person p2 -name gustaf
Person p3 -name frido
Article a1 -title "My life as a saint" -date "1.1.2006"
publishes new -written_by p1 -has_published a1
set p [Project new -name icamp -manager p2 -member add p1 -member add p3]
$p member add X end
puts [$p member]

? [list $p fullbudget] 100
? [list $p fullbudget] 100
? [list $p currentbudget] 99
? [list $p currentbudget] 98
? [list $p fullbudget 200] 200
? [list $p currentbudget] 199
exit

foreach o [Object allinstances] {
  if {[$o isclass]} continue
  if {[$o istype Slot]} continue
  if {$o eq "::xotcl::relmgr"} continue
  set string "$o\n"
  foreach v [$o info vars] {
    append string "   $v = [$o set $v]\n"
  }
  puts $string
}

puts stderr DONE-[p1 name]-[p1 age]

p3 age 77
exit

puts [XoXML asXML]

puts ====
foreach n [XoXML selectNodes {//object[age > 1]}]  {puts [$n asXML]}

exit