package require XOTcl
package require xotcl::test

proc ? {cmd expected {msg ""}} {
  set count 10
  if {$msg ne ""} {
    set t [Test new -cmd $cmd -count $count -msg $msg]
  } else {
    set t [Test new -cmd $cmd -count $count]
  }
  $t expected $expected 
  $t run
}

::xotcl::use xotcl2

Class create Base
Base method foo {{-x 1}} {return $x}

Class create Foo
::xotcl::alias ::Foo foo ::xotcl::classes::Base::foo

Foo create f1
? {f1 foo} 1
? {f1 foo -x 2} 2
? {Foo info methods -defined -methodtype alias} "foo"

? {Base info methods -defined -methodtype scripted} {foo}
? {Foo info methods -defined -methodtype scripted} {foo}
Base method foo {} {}
? {Foo info methods -defined -methodtype alias} ""
? {Base info methods -defined -methodtype scripted} {}
? {Foo info methods -defined -methodtype scripted} {}

Base method foo {{-x 1}} {return $x}
::xotcl::alias ::Foo foo ::xotcl::classes::Base::foo

? {Base info methods -defined -methodtype scripted} {foo} "defined again"
? {Foo info methods -defined -methodtype scripted} {foo} "aliased again"
Foo method foo {} {}
? {Base info methods -defined -methodtype scripted} {foo} "still defined"
? {Foo info methods -defined -methodtype scripted} {} "removed"

#
# chaining aliases
#

Class create T
Class create S
T create t
S create s


T method foo args { return [self class]->[self proc] }
::xotcl::alias T FOO ::xotcl::classes::T::foo 

? {t foo} ::T->foo
? {t FOO} ::T->foo

? {lsort [T info methods -defined -methodtype scripted]} {FOO foo}
T method foo {} {}
? {lsort [T info methods -defined -methodtype scripted]} {} "alias is deleted"

# puts stderr "double indirection"
T method foo args { return [self class]->[self proc] }
::xotcl::alias T FOO ::xotcl::classes::T::foo 
::xotcl::alias S BAR ::xotcl::classes::T::FOO

? {lsort [T info methods -defined -methodtype scripted]} {FOO foo}
? {S info methods -defined -methodtype scripted} {BAR}
T method FOO {} {}
? {T info methods -defined -methodtype scripted} {foo}
? {S info methods -defined -methodtype scripted} {BAR}
? {s BAR} ::S->foo
? {t foo} ::T->foo

T method foo {} {}
? {T info methods -defined -methodtype scripted} {}
? {S info methods -defined -methodtype scripted} {}

T method foo args { return [self class]->[self proc] }
::xotcl::alias T FOO ::xotcl::classes::T::foo 
::xotcl::alias S BAR ::xotcl::classes::T::FOO

? {lsort [T info methods -defined -methodtype scripted]} {FOO foo}
? {S info methods -defined -methodtype scripted} {BAR}
T method foo {} {}
? {S info methods -defined -methodtype scripted} {}
? {T info methods -defined -methodtype scripted} {}

T method foo args { return [self class]->[self proc] }
T method -per-object bar args { return [self class]->[self proc] }
::xotcl::alias T FOO -per-object ::xotcl::classes::T::foo 
::xotcl::alias T BAR -per-object ::T::FOO 
::xotcl::alias T ZAP -per-object ::T::BAR 
? {T info methods -defined -methodtype scripted} {foo}
? {lsort [T info methods -defined -per-object -methodtype alias]} {BAR FOO ZAP}
? {lsort [T info methods -per-object -defined -methodtype scripted]} {BAR FOO ZAP bar}
? {t foo} ::T->foo
#
# ISSUE: Why does a [self class] in per-object aliases on method procs
# resolves to [::xotcl::Class]
#
? {T FOO} ->foo
? {T BAR} ->foo
? {T ZAP} ->foo
? {T bar} ->bar
T method -per-object FOO {} {}
? {T info methods -defined -methodtype scripted} {foo}
? {lsort [T info methods -per-object -defined -methodtype scripted]} {BAR ZAP bar}
? {T BAR} ->foo
? {T ZAP} ->foo
rename ::T::BAR ""
? {T info methods -defined -methodtype scripted} {foo}
? {lsort [T info methods -per-object -defined -methodtype scripted]} {ZAP bar}
#? {T BAR} ""; #  now calling the proc defined above, alias chain seems intact
? {T ZAP} ->foo; # is ok, still pointing to 'foo'
#T method -per-object BAR {} {}
? {T info methods -defined -methodtype scripted} {foo}
? {lsort [T info methods -per-object -defined -methodtype scripted]} {ZAP bar}
? {T ZAP} ->foo
T method foo {} {}
? {T info methods -defined -methodtype scripted} {}
? {lsort [T info methods -per-object -defined -methodtype scripted]} {bar}

#
# per-object methods as per-object aliases
#
T method -per-object m1 args { return [self class]->[self proc] }
::xotcl::alias T M1 -per-object ::T::m1 
::xotcl::alias T M11 -per-object ::T::M1 
? {lsort [T info methods -per-object -defined -methodtype scripted]} {M1 M11 bar m1}
? {T m1} ->m1
? {T M1} ->m1
? {T M11} ->m1
T method -per-object M1 {} {}
? {lsort [T info methods -per-object -defined -methodtype scripted]} {M11 bar m1}
? {T m1} ->m1
? {T M11} ->m1
T method -per-object m1 {} {}
? {lsort [T info methods -per-object -defined -methodtype scripted]} {bar}

#
# a proc as alias
#

proc foo args { return [self class]->[self proc] }
::xotcl::alias T FOO1 ::foo 
::xotcl::alias T FOO2 -per-object ::foo
#
# ! per-object alias referenced as per-class alias !
#
::xotcl::alias T BAR ::T::FOO2
? {lsort [T info methods -per-object -defined -methodtype scripted]} {FOO2 bar}
? {lsort [T info methods -defined -methodtype scripted]} {BAR FOO1}
? {T FOO2} ->foo
? {t FOO1} ::T->foo
? {t BAR} ::T->foo
#
# delete proc
#
rename foo ""
? {lsort [T info methods -per-object -defined -methodtype scripted]} {bar}
? {lsort [T info methods -defined -methodtype scripted]} {}

# namespaced procs + namespace deletion

namespace eval ::ns1 {
  proc foo args { return [self class]->[self proc] }
  proc bar args { return [uplevel 2 {set _}] }
  proc bar2 args { upvar 2 _ __; return $__}
}

::xotcl::alias T FOO ::ns1::foo
::xotcl::alias T BAR ::ns1::bar
::xotcl::alias T BAR2 ::ns1::bar2
? {lsort [T info methods -defined -methodtype scripted]} {BAR BAR2 FOO}
set _ GOTYA
? {t FOO} ::T->foo
? {t BAR} GOTYA
? {t BAR2} GOTYA
namespace delete ::ns1
? {info procs ::ns1::*} {}
? {lsort [T info methods -defined -methodtype scripted]} {}

# per-object namespaces

Class create U
U create u
? {namespace exists ::U} 0
U method -per-object zap args { return [self class]->[self proc] }
::xotcl::alias ::U ZAP -per-object ::U::zap 
U requireNamespace
? {namespace exists ::U} 1

U method -per-object bar args { return [self class]->[self proc] }
::xotcl::alias U BAR -per-object ::U::bar
? {lsort [U info methods -per-object -defined -methodtype scripted]} {BAR ZAP bar zap}
? {U BAR} ->bar
? {U ZAP} ->zap
namespace delete ::U
? {namespace exists ::U} 0
? {lsort [U info methods -per-object -defined -methodtype scripted]} {}
? {U procsearch BAR} ""
? {U procsearch ZAP} ""

::U destroy

# dot-resolver/ dot-dispatcher used in aliased proc

Class create V {
  set .z 1
}

V create v {
  set .z 2
}

V method bar {z} { return $z }

V method -per-object bar {z} { return $z }

proc foo args { return [.bar ${.z}]-[set .z]-[my bar [set .z]] }

::xotcl::alias V FOO1 ::foo 
::xotcl::alias V FOO2 -per-object ::foo
? {lsort [V info methods -per-object -defined -methodtype scripted]} {FOO2 bar}
? {lsort [V info methods -defined -methodtype scripted]} {FOO1 bar}
? {V FOO2} 1-1-1
? {v FOO1} 2-2-2
V method FOO1 {} {}
? {lsort [V info methods -defined -methodtype scripted]} {bar}
rename ::foo ""
? {lsort [V info methods -per-object -defined -methodtype scripted]} {bar}