# -*- Tcl -*-
package require XOTcl; namespace import ::xotcl::*
package require next::test

###########################################
# trivial object delegation
###########################################
Test case delegation
Object dog
Object tail
tail proc wag args { return $args }
dog forward wag tail %proc

? {dog wag 100} 100


###########################################
# evaluating in scope 
###########################################
Test case inscope
Class X -parameter {{x 1}}
X instforward Incr -objscope incr

X x1 -x 100
x1 Incr x
x1 Incr x
x1 Incr x
? {x1 x} 103
#puts "======"

###########################################
# adding 
###########################################
Test case adding
Object obj
obj forward addOne expr 1 +

? {obj addOne 5} 6
#puts stderr "======"

###########################################
# more arguments
###########################################
Test case multiple-args
Object target
target proc foo args {return $args}
obj forward foo target %proc %self a1 a2

? {obj foo x1 x2} [list ::obj a1 a2 x1 x2]

obj forward foo target %proc %self %%self %%p
? {obj foo x1 x2} [list ::obj %self %p x1 x2]

#puts "======"


###########################################
# mixin example
###########################################
Test case mixin-via-forward
Object create mixin
mixin proc unknown {m args} {return [concat [self] $m $args]}
 
obj forward Mixin mixin %1 %self
? {obj Mixin add M1} [list ::mixin add ::obj M1]
? {catch {obj Mixin}} 1


obj forward Mixin mixin "%1 {Getter Setter}" %self
? {obj Mixin add M1} [list ::mixin add ::obj M1]
? {obj Mixin M1} [list ::mixin Setter ::obj M1]
? {obj Mixin} [list ::mixin Getter ::obj]
#puts "======"


###########################################
# sketching extensibe info
###########################################
Test case info-via-forward
Object Info
Info proc @mixin {o} {
  $o info mixin
}
Info proc @class {o} { ;# without prefix, doing here a [Info class] wod be wrong
  $o info class
}
Info proc @help {o} { ;# define a new subcommand for info
  foreach c [my info procs] {lappend result [string range $c 1 end]}
  return $result
}
Object instforward Info -methodprefix @ Info %1 %self 

? {x1 Info class} ::X
? {x1 Info help} [list help mixin class]

###########################################
# variations of placement of options
###########################################
Test case incr
obj set x 1
obj forward i1 -objscope incr x 

? {obj i1} 2
#puts "======"

###########################################
# introspeciton options
###########################################
Test case introspection
Class C 
C instforward Info -methodprefix @ Info %1 %self 

? {C info instforward} Info
C instforward XXXo x
? {lsort [C info instforward]} [list Info XXXo]

? {C info instforward X*} [list XXXo]
? {lsort [C info instforward *o]} [list Info XXXo]

# delete the forwarder
C instproc XXXo {} {}
? {C info instforward} [list Info]
# get the definition of a instforwarder
? {C info instforward -definition Info} [list -methodprefix @ Info %1 %self]

# check introspection for objects
? {lsort [obj info forward]} "Mixin addOne foo i1"
? {obj info forward -definition Mixin} "mixin {%1 {Getter Setter}} %self"
? {obj info forward -definition addOne} "expr 1 +"
? {obj info forward -definition foo} "target %proc %self %%self %%p"
? {obj info forward -definition i1} "-objscope ::incr x"
#puts stderr "======"

###########################################
# test serializer
###########################################
Test case serializer
package require xotcl::serializer
obj proc test {} {puts "i am [self proc]"}
set a [Serializer deepSerialize obj]
#puts <<$a>>
eval $a
? {set ::a} [Serializer deepSerialize obj]

###########################################
# test optional target cmd
###########################################
Test case optional-target
obj set x 2
obj forward append -objscope
? {obj append x y z} 2yz

Object n; Object n::x; Object o; 
o forward ::n::x
? {o x self} ::n::x

###########################################
# arg including instvar
###########################################
Test case percent-cmd
obj set x 10
obj forward x* expr {%my set x} *
? {obj x* 10} "100"

###########################################
# positional arguments
###########################################
Test case positioning-args
obj forward @end-13 list {%@end 13}
? {obj @end-13 1 2 3 } [list 1 2 3 13]

obj forward @-1-13 list {%@-1 13}
? {obj @-1-13 1 2 3 } [list 1 2 13 3]

obj forward @1-13 list {%@1 13}
? {obj @1-13 1 2 3 } [list 13 1 2 3]
? {obj @1-13} [list 13]

obj forward @2-13 list {%@2 13}
? {obj @2-13 1 2 3 } [list 1 13 2 3]

obj forward @list 10 {%@0 list} {%@end 99}
? {obj @list} [list 10 99]
? {obj @list a b c} [list 10 a b c 99]

obj forward @list {%@end 99} {%@0 list} 10
? {obj @list} [list 10 99]
? {obj @list a b c} [list 10 a b c 99]

obj forward @list {%@2 2} {%@1 1} {%@0 list}
? {obj @list} [list 1 2]
? {obj @list a b c} [list 1 2 a b c]

obj forward @list x y z {%@0 list} {%@1 1} {%@2 2} 
? {obj @list} [list 1 2 x y z]
? {obj @list a b c} [list 1 2 x y z a b c]

obj forward @list x y z {%@2 2} {%@1 1} {%@0 list}
? {obj @list} [list x 1 y 2 z]
? {obj @list a b c} [list x 1 y 2 z a b c]

# adding some test cases which cover the interactions
# between %@POS and %1 substitutions
#

obj forward @end-13 list {%@end 13} %1 %self
? {obj @end-13 1 2 3 } [list 1 ::obj 2 3 13]

obj forward @end-13 list %1 {%@end 13} %self
? {obj @end-13 1 2 3 } [list 1 ::obj 2 3 13]

obj forward @end-13 list {%@end 13} %1 %1 %1 %self
? {obj @end-13 1 2 3 } [list 1 1 1 ::obj 2 3 13]

obj forward @end-13 list {%@-1 13} %1 %self
? {obj @end-13 1 2 3 } [list 1 ::obj 2 13 3]

obj forward @end-13 list {%@1 13} %1 %self
? {obj @end-13 1 2 3 } [list 13 1 ::obj 2 3]

###############################################
# substitution depending on number of arguments
###############################################
Test case num-args
obj forward f %self [list %argclindex [list a b c]]
obj proc a args {return [list [self proc] $args]}
obj proc b args {return [list [self proc] $args]}
obj proc c args {return [list [self proc] $args]}
? {obj f} [list a {}]
? {obj f 1 } [list b 1]
? {obj f 1 2} [list c {1 2}]
? {catch {obj f 1 2 3}} 1

###############################################
# option earlybinding
###############################################
Test case earlybinding
obj forward s -earlybinding ::set ::X
? {obj s 100} 100
? {obj s} 100

Object instproc f args { next }          

Class NS	
Class NS::Main

NS::Main proc m1 {} { my m2 }

NS::Main proc m2 {} {
  ? {namespace eval :: {Object toplevelObj1}} ::toplevelObj1
  
  ? [list set _ [namespace current]] ::NS
  ? [list set _ [NS create m1]] ::NS::m1
  NS filter f
  ? [list set _ [NS create m2]] ::NS::m2
  NS filter ""

  namespace eval ::test {
    ? [list set _ [NS create m3]] ::test::m3
    NS filter f
    ? [list set _ [NS create m4]] ::test::m4
    NS filter ""
  }

  namespace eval test {
    ? [list set _ [NS create m5]] ::NS::test::m5
    NS filter f
    ? [list set _ [NS create m6]] ::NS::test::m6
    NS filter ""
  }

}

NS::Main instproc i1 {} { my i2 }

NS::Main instproc i2 {} {
  ? {namespace eval :: {Object toplevelObj2}} ::toplevelObj2
  
  ? [list set _ [namespace current]] ::NS
  ? [list set _ [NS create i1]] ::NS::i1
  NS filter f
  ? [list set _ [NS create i2]] ::NS::i2
  NS filter ""

  namespace eval ::test {
    ? [list set _ [NS create i3]] ::test::i3
    NS filter f
    ? [list set _ [NS create i4]] ::test::i4
    NS filter ""
  }

  namespace eval test {
    ? [list set _ [NS create i5]] ::NS::test::i5
    NS filter f
    ? [list set _ [NS create i6]] ::NS::test::i6
    NS filter ""
  }

}

#puts ====
NS::Main m1
NS::Main create m
m i1

#puts ====
? [list set _ [NS create n1]] ::n1
NS filter f
? [list set _ [NS create n2]] ::n2
NS filter ""

#puts ====
namespace eval test {
  ? [list set _ [NS create n1]] ::test::n1
  ? [list set _ [NS create n3]] ::test::n3
  NS filter f
  ? [list set _ [NS create n4]] ::test::n4
  NS filter ""
}

###########################################
# forward to expr + callstack
###########################################
Test case callstack
Object instforward expr -objscope

Class C
C instproc xx {} {self}
C proc t {o expr} {
  return [$o expr $expr]
}
C create c1

#puts ====
? {c1 expr {[self]}} 		::c1
? {c1 expr {[self] == "::c1"}} 	1
? {c1 expr {[my xx]}} 		::c1
? {c1 expr {[my info class]}} 	::C
? {c1 expr {[my istype C]}} 	1
? {c1 expr {[my istype ::C]}} 	1

? {C t ::c1 {[self]}} 		::c1
? {C t ::c1 {[self] == "::c1"}} 1
? {C t ::c1 {[my xx]}} 		::c1
? {C t ::c1 {[my info class]}} ::C
? {C t ::c1 {[my istype C]}} 	1
? {C t ::c1 {[my istype ::C]}} 	1