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 xotcl1
::xotcl::use xotcl2

# the system methods of Object are either alias or forwarders
? {lsort [::xotcl::Slot info methods -methodtype alias]} {assign get}
? {::xotcl::Slot info method definition get} "::xotcl::Slot alias get ::xotcl::setinstvar"

set cmd "::xotcl2::Object alias -objscope set ::set"
eval $cmd
? {Object info method definition set} $cmd

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

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

? {Foo info method definition foo} "::Foo alias foo ::xotcl::classes::Base::foo"

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

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


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

? {Base info methods -methodtype scripted} {foo} "defined again"
? {Foo info methods -methodtype scripted} {foo} "aliased again"
Foo method foo {} {}
? {Base info methods -methodtype scripted} {foo} "still defined"
? {Foo info methods -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 -methodtype scripted]} {FOO foo}
T method foo {} {}
? {lsort [T info methods -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

? {T info methods -methodtype alias} "FOO"
? {T info method definition FOO} "::T alias FOO ::xotcl::classes::T::foo"
? {lsort [T info methods -methodtype scripted]} {FOO foo}
? {S info methods -methodtype scripted} {BAR}
T method FOO {} {}
? {T info methods -methodtype scripted} {foo}
? {S info methods -methodtype scripted} {BAR}
? {s BAR} ::S->foo
? {t foo} ::T->foo
? {S info method definition BAR} "::S alias BAR ::xotcl::classes::T::FOO"


T method foo {} {}
? {T info methods -methodtype scripted} {}
? {S info methods -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 -methodtype scripted]} {FOO foo}
? {S info methods -methodtype scripted} {BAR}
T method foo {} {}
? {S info methods -methodtype scripted} {}
? {T info methods -methodtype scripted} {}

T method foo args { return [self class]->[self proc] }
T object method bar args { return [self class]->[self proc] }
::xotcl::alias T -per-object FOO ::xotcl::classes::T::foo 
::xotcl::alias T -per-object BAR ::T::FOO 
::xotcl::alias T -per-object ZAP ::T::BAR 
? {T info methods -methodtype scripted} {foo}
? {lsort [T object info methods -methodtype alias]} {BAR FOO ZAP}
? {lsort [T object info methods -methodtype scripted]} {BAR FOO ZAP bar}
? {t foo} ::T->foo
? {T object info method definition ZAP} {::T object alias ZAP ::T::BAR}

? {T FOO} ->foo
? {T BAR} ->foo
? {T ZAP} ->foo
? {T bar} ->bar
T object method FOO {} {}
? {T info methods -methodtype scripted} {foo}
? {lsort [T object info methods -methodtype scripted]} {BAR ZAP bar}
? {T BAR} ->foo
? {T ZAP} ->foo
rename ::T::BAR ""
? {T info methods -methodtype scripted} {foo}
? {lsort [T object info methods -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 object method BAR {} {}
? {T info methods -methodtype scripted} {foo}
? {lsort [T object info methods -methodtype scripted]} {ZAP bar}
? {T ZAP} ->foo
T method foo {} {}
? {T info methods -methodtype scripted} {}
? {lsort [T object info methods -methodtype scripted]} {bar}

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

#
# a proc as alias
#

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

# per-object namespaces

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

U object method bar args { return [self class]->[self proc] }
::xotcl::alias U -per-object BAR ::U::bar
? {lsort [U object info methods -methodtype scripted]} {BAR ZAP bar zap}
? {U BAR} ->bar
? {U ZAP} ->zap
namespace delete ::U
? {namespace exists ::U} 0
? {lsort [U object info methods -methodtype scripted]} {}
? {U info callable BAR} ""
? {U info callable 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 object method bar {z} { return $z }

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

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


#
# Tests for the ::xotcl::alias store, used for introspection for
# aliases. The alias store (an associative variable) is mostly
# necessary for for the direct aliases (e.g. aliases to C implemented
# tcl commands), for which we have no stubs at the place where the
# alias was registered.
#
::xotcl::use xotcl2

#
# structure of the ::xotcl::alias store:
# <object>,<alias_name>,<per_object> -> <aliased_cmd>
#

Object create o
Class create C

o method bar args {;}

? {info vars ::xotcl::alias} ::xotcl::alias
? {array exists ::xotcl::alias} 1 

proc ::foo args {;}
::xotcl::alias ::o FOO ::foo
::xotcl::alias ::C FOO ::foo
? {info exists ::xotcl::alias(::o,FOO,1)} 1
? {info exists ::xotcl::alias(::C,FOO,0)} 1
? {array get ::xotcl::alias ::o,FOO,1} "::o,FOO,1 ::foo"
? {array get ::xotcl::alias ::C,FOO,0} "::C,FOO,0 ::foo"
? {o info method definition FOO} "::o alias FOO ::foo"
? {C info method definition FOO} "::C alias FOO ::foo"

::xotcl::alias o FOO ::o::bar
? {info exists ::xotcl::alias(::o,FOO,1)} 1
? {array get ::xotcl::alias ::o,FOO,1} "::o,FOO,1 ::o::bar"
? {o info method definition FOO} "::o alias FOO ::o::bar"

# AliasDelete in XOTclRemoveObjectMethod
o method FOO {} {}
? {info exists ::xotcl::alias(::o,FOO,1)} 0
? {array get ::xotcl::alias ::o,FOO,1} ""
? {o info method definition FOO} ""

# AliasDelete in XOTclRemoveClassMethod
C method FOO {} {}
? {info exists ::xotcl::alias(::C,FOO,0)} 0
? {array get ::xotcl::alias ::C,FOO,0} ""
? {C info method definition FOO} ""

::xotcl::alias ::o BAR ::foo
::xotcl::alias ::C BAR ::foo  

# AliasDelete in XOTclAddObjectMethod
? {info exists ::xotcl::alias(::o,BAR,1)} 1
::o method BAR {} {;}
? {info exists ::xotcl::alias(::o,BAR,1)} 0

# AliasDelete in XOTclAddInstanceMethod
? {info exists ::xotcl::alias(::C,BAR,0)} 1
::C method BAR {} {;}
? {info exists ::xotcl::alias(::C,BAR,0)} 0

# AliasDelete in aliasCmdDeleteProc
::xotcl::alias o FOO ::foo
? {info exists ::xotcl::alias(::o,FOO,1)} 1
rename ::foo ""
? {info exists ::xotcl::alias(::o,FOO,1)} 0

::xotcl::alias o FOO ::o::bar
::xotcl::alias o BAR ::o::FOO
? {info exists ::xotcl::alias(::o,FOO,1)} 1
? {info exists ::xotcl::alias(::o,BAR,1)} 1
o method bar {} {}
? {info exists ::xotcl::alias(::o,FOO,1)} 0
? {info exists ::xotcl::alias(::o,BAR,1)} 0

#
# pulling the rug out from the proc-alias deletion mechanism
#

proc ::foo args {;}
::xotcl::alias C FOO ::foo
? {info exists ::xotcl::alias(::C,FOO,0)} 1
unset ::xotcl::alias(::C,FOO,0)
? {info exists ::xotcl::alias(::C,FOO,0)} 0
? {C info method definition FOO} ""
? {C info methods -methodtype alias} FOO
rename ::foo ""
? {C info methods -methodtype alias} ""
? {info exists ::xotcl::alias(::C,FOO,0)} 0
? {C info method definition FOO} ""

#
# test renaming of Tcl proc (actually sensed by the alias, though not
# reflected by the alias definition store)
# a) is this acceptable?
# b) sync ::xotcl::alias upon "info method definition" calls? is this feasible,
# e.g. through rename traces?
#

C create c
proc ::foo args { return [self]->[self proc]}
? {info exists ::xotcl::alias(::C,FOO,0)} 0
::xotcl::alias C FOO ::foo
? {info exists ::xotcl::alias(::C,FOO,0)} 1
? {C info methods -methodtype alias} FOO
rename ::foo ::foo2
? {info exists ::xotcl::alias(::C,FOO,0)} 1
? {C info methods -methodtype alias} FOO
? {c FOO} ::c->foo2
? {C info method definition FOO} "::C alias FOO ::foo"; # should be ::foo2 (!)