set auto_path [concat . $auto_path]
#########################################################################
#
# Implementation of ITcl based on the Minimal Object System + XOTcl methods
#
#########################################################################
#
# This script consists of three major parts:
#
#   1. Setup of XOTcl to be used as Tcl Minimal Object System (TMOS)
#   2. The definition of a subset of itcl based on TMOS. 
#   3. Sample itcl program 
#

######################################################################
#
# 1. Configuration of XOTcl to act as the Tcl Minimal Object System
#
###################################################################### 
# For the time being, we use the XOTcl implementation for implementing
# TMOS. The used part of the XOTcl implementation should 
# be part of tcl-core. 
#
# http://media.wu-wien.ac.at/download/xotcl-1.5.3-alpha.tar.gz

puts "***** time for loading XOTcl [time {set version [package require XOTcl]}]"
puts "XOTcl version $version"

namespace eval ::xotcl {
  namespace export alias setrelation
  namespace eval cmd::Class {namespace export alloc dealloc instproc instforward info}
  namespace eval cmd::Object {namespace export instvar forward info}
}
namespace eval ::oo  {
  namespace import ::xotcl::alias ::xotcl::setrelation
  namespace import ::xotcl::my ::xotcl::self ::xotcl::next
  namespace eval ::oo::methodset::class  {namespace import ::xotcl::cmd::Class::*}
  namespace eval ::oo::methodset::object {namespace import ::xotcl::cmd::Object::*}
  namespace export my self next
}

# The remainder of this script is free of xotcl::*.


######################################################################
#
# Basic setup of the Tcl minimal object system (TMOS)
#
###################################################################### 

# Now we have the following commands and methods defined in the ::oo namespace:
#
# Two classes
#   ::oo::class
#   ::oo::object
#
# Two unexported commands for OO-language designer
#   ::oo::alias
#   ::oo::setrelation
#
# Three exported commands to be used by in the languages
#   ::oo::my
#   ::oo::self
#   ::oo::next 
#
# An unregistered (unattached) set of methods that can be used for classes
#   alloc, instproc, instforward, info
#
# An unregistered (unattached) set of methods that can be used to objects
#   instvar forward info

# The only method provided by ::oo::class is the the method "alloc"
# used to create objects or classes. This method is available in the
# methodset of oo. We will attach it to ::oo::class using the command
# alias:
#
# The alias command 
#
#    ::oo::alias class|obj methodName ?-objscope? ?-per-object? cmdName
#
# registers a command ("cmdName") under a certain name ("methodName")
# to an object or class (1st argument) to make the command available 
# as a method. The options "-objscope" makes instance variables of the
# object/class appear as local variables, therefore Tcl commands to which
# variable names are passed (e.g. set, append, lappend, ...) will access
# instance variables. 

::oo::alias ::oo::class alloc ::oo::methodset::class::alloc
::oo::alias ::oo::class dealloc ::oo::methodset::class::dealloc

#
# Ok. now our basic setup of the Tcl minimal object system is done. 

######################################################################
#
# 2. ITcl based on TMOS
#
###################################################################### 

namespace eval itcl {

  # In a first step, we create two basic classes of ITcl, 
  # namely "object" and "class"  in the current namespace:
  
  oo::class alloc object
  oo::class alloc class

  ::oo::setrelation class superclass {::oo::class object} 
  ::oo::setrelation object class class 
  ::oo::setrelation class  class class 

  ::oo::alias class __method    ::xotcl::cmd::Class::classscopedinstproc
  ::oo::alias class __info      ::oo::methodset::class::info

  ::oo::alias object __instvar  ::oo::methodset::object::instvar
  ::oo::alias object __info     ::oo::methodset::object::info
  ::oo::alias object __forward  ::oo::methodset::object::forward  ;# for append/lappend on stateobj
  ::oo::alias object __proc     ::xotcl::cmd::Object::proc        ;# for defining class.proc

  ::xotcl::setinstvar class  __default_superclass ::itcl::object
  #
  # The method "create" defines, what happens, when a class or object 
  # is created. The object|class is firstly allocated, then the constructor is called.
  #
  class __proc create {name args} {
    set obj [uplevel 2 [::itcl::self] alloc $name]
    #puts "creating class $name -> $obj"
    eval $obj init $args
    return "" ;# for unknown reasons, a class create returns "" in ITcl
  }
  class __method create {name args} {
    if {[::info command [uplevel 2 namespace current]::$name] ne ""} {
      error "command \"$name\" already exists in namespace \"[uplevel 2 namespace current]\""
    }
    #puts "creating object $name"
    set obj [uplevel 2 [::itcl::self] alloc $name]
    #puts obj=$obj-methods=[$obj __info methods],[my __info instbody init]
    eval $obj constructor $args
    return [string trimleft $obj :] ;# for unknown reasons, craated objects are not fq in ITcl
  }

  # provide primitive commands; we use these from oo
  namespace import ::oo::my ::oo::self ::oo::next

  class __method instvars {} {
    set vars [list this]
    set stateobj [::itcl::self]::__
    foreach v [$stateobj set privinstvars] {lappend vars [lindex $v 0]}
    for {set c [::itcl::self]} {$c ne "::itcl::object"} {set c [$c __info superclass]} {
      foreach v [${c}::__ set instvars] {lappend vars [lindex $v 0]}
    }
    set cmd "\n\t::itcl::my __instvar [lsort -unique $vars]"
    set cvars [list]
    foreach v [$stateobj set privclassvars] {lappend cvars [lindex $v 0]}
    if {$cvars ne ""} {
      append cmd "\n\t[::itcl::self] __instvar [lsort -unique $cvars]"
    }
    for {set c [::itcl::self]} {$c ne "::itcl::object"} {set c [$c __info superclass]} {
      set cvars [list]
      foreach v [${c}::__ set classvars] {lappend cvars [lindex $v 0]}
      if {[llength $cvars]>0} {append cmd "\n\t$c __instvar [lsort -unique $cvars]"}
    }
    return $cmd
  }

  namespace eval ::itcl::classdefs {
    proc constructor {args}   {[::itcl::self]::__ set constructor $args}
    proc destructor {body}    {::itcl::mk_member method destroy {} "$body\n::itcl::next"}
    proc method {name args}   {eval ::itcl::mk_member method $name $args}
    proc inherit {class}      {::oo::setrelation [::itcl::self] superclass $class}
    proc variable {name args} {eval ::itcl::mk_member variable $name $args}
    proc common {name args}   {eval ::itcl::mk_member common $name $args}

    proc public args          {if {[llength $args]==1} {eval [lindex $args 0]} {eval $args}}
    proc protected args       {if {[llength $args]==1} {eval [lindex $args 0]} {eval $args}}
    proc private args         {if {[llength $args]==1} {eval [lindex $args 0]} {eval $args}}

    proc set    {name args}   {namespace eval [::itcl::self] [list ::set $name $args]}
    proc proc   {name args}   {eval ::itcl::mk_member proc $name $args}
  }

  proc mk_member {kind name args} {
    # get the protection from the stack: a member is protected, if "protected" in on the stack
    set u [lindex [::info level -2] 0]
    set protection [expr {$u ne "protected" && $u ne "private" ? "public" : $u}]
    #puts "p=$protection k=$kind n=$name  u='[lindex [::info level -2] 0]'"
    set stateobj [::itcl::self]::__
    switch $kind {
      variable {
        set varname [expr {$protection eq "private" ? "privinstvars" : "instvars"}]
        $stateobj lappend $varname [list $name [lindex $args 0] [lindex $args 1] $protection]
        if {[llength $args] > 0} {
          $stateobj append initcommands [list set $name [lindex $args 0]]\n
        }
      }
      common {
        set varname [expr {$protection eq "private" ? "privclassvars" : "classvars"}]
        $stateobj lappend $varname [list $name [lindex $args 0] $protection]
        if {[llength $args] > 0} {::xotcl::setinstvar [::itcl::self] $name [lindex $args 0]}
      }
      method {
        $stateobj lappend methods $name [lindex $args 0] [lindex $args 1] $protection
      }
      proc {
        $stateobj lappend procs $name [lindex $args 0] [lindex $args 1] $protection
      }
    }
  }

  proc called_from_outside {callingclass currentclass proc} {
    # returns true, when not called from within a subtree of callingclass
    # returns as well true, when callingclass an has overloaded protected (last clause)
    expr {$callingclass ne $currentclass &&
          ( $callingclass eq "::" ||
            ![::xotcl::istype $callingclass ::itcl::class] ||
            ([lsearch -exact [$callingclass __info heritage] $currentclass] == -1 &&
             [::info command ${callingclass}::$proc] eq ""))}
  }
  
  class __method init {classdef} {
    # keep the variables of the configuration of a class in an object to avoid
    # naming conflicts with "common" variables in itcl
    set stateobj [::itcl::self]::__
    ::itcl::object alloc $stateobj
    ::oo::alias  $stateobj set ::xotcl::cmd::Object::set
    $stateobj __forward lappend -objscope ::lappend
    $stateobj __forward append -objscope ::append
    $stateobj set constructor [list "" ::itcl::next]
    $stateobj set procs [list]
    $stateobj set methods [list]
    $stateobj set instvars [list]
    $stateobj set privinstvars [list]
    $stateobj set classvars [list]
    $stateobj set privclassvars [list]
    $stateobj set initcommands "set this \[::itcl::self\]\n"
    $stateobj set auto -1

    # interprete the defininition of the class
    namespace eval ::itcl::classdefs $classdef

    # now, the definition is placed into a few variables. process the definition now
    $stateobj __instvar constructor procs methods initcommands

    # add the constructor to the method definitions
    lappend methods constructor [lindex $constructor 0] \
        "$initcommands [lindex $constructor 1][lindex $constructor 2]" public

    # process the methods
    foreach {methodName arglist body protection} $methods {
      switch $protection {
        public     {set protectionCmds ""}
        protected  {set protectionCmds {
          set callingclass [uplevel namespace current]
          set currentclass [namespace current]
          #puts "protected [::itcl::self proc] callingclass=$callingclass, current=$currentclass"
          set outside [::itcl::called_from_outside $callingclass $currentclass [::itcl::self proc]]
          if {$outside} {
            #puts stderr "M=[::itcl::get_my_methods $currentclass]"
            set options [string trim [::itcl::get_my_methods $currentclass $callingclass] \n]
            error "bad option \"[::itcl::self proc]\": should be one of...\n$options"
          }
        }}
        private    {set protectionCmds {
          set callingclass [uplevel namespace current]
          set currentclass [namespace current]
          #puts "private [::itcl::self proc] callingclass=$callingclass, current=$currentclass"
          if {$callingclass ne $currentclass} {
            set options [string trim [::itcl::get_my_methods $currentclass $callingclass] \n]
            error "bad option \"[::itcl::self proc]\": should be one of...\n$options"
          }
        }}
        default {error "unknown protection '$protection'"}
      }
      set initvarCmds [expr {[::itcl::self] eq "::itcl::object" ? "" : "[::itcl::my instvars]\n"}]
      #puts "defining $methodName $arglist\n\t$protectionCmds\n$initvarCmds\n $body"
      ::itcl::my __method $methodName $arglist "$protectionCmds\n$initvarCmds\n $body"
    }

    # define reflector methods for calling inherited methods without objectname/::itcl::my
    for {set c [::itcl::self]} {$c ne "::oo::object"} {set c [$c __info superclass]} {
      foreach {methodName _ _ protection} [${c}::__ set methods] {
        if {$protection eq "private" && $c ne [::itcl::self]} continue
        if {[::info command [::itcl::self]::$methodName] eq ""}  {
          #puts "+++ c = $c, creating reflector for [::itcl::self] $methodName // $protection"
          namespace eval ::xotcl::classes::$c [list namespace export $methodName]
          namespace eval [::itcl::self] [list namespace import ::xotcl::classes::${c}::$methodName]
        }
      }
    }
    
    # process the procs 
    foreach {methodName arglist body protection} $procs {
      switch $protection {
        public     {set protectionCmds ""}
        protected  {set protectionCmds {
          set uns [uplevel namespace current]
          #puts "protected proc [namespace current] uns=$uns"
          if {[namespace current] ne $uns} {
            if {$uns eq "::" || [lsearch -exact [$uns __info heritage] [namespace current]] == -1} {
              error "can't access \"::[::info level 0]\": protected function"
            }}}
        }
        private  {set protectionCmds {;# for now, like protected
          #puts "private proc [namespace current] uns=[uplevel namespace current]"
          if {[namespace current] ne [uplevel namespace current]} {
            error "can't access \"::[::info level 0]\": private function"
          }}
        }
      }

      set cmds ""
      set vars [concat [$stateobj set classvars] [$stateobj set privclassvars] ]
      foreach v $vars {append cmds "::variable [lindex $v 0]\n"}
      #puts "::proc [::itcl::self]::$methodName $arglist {$cmds\n$protectionCmds\n$body}"
      ::proc [::itcl::self]::$methodName $arglist "$cmds\n$protectionCmds\n$body"
    }
    
    # define reflectors for the procs of the parent classes
    for {set c [[::itcl::self] __info superclass]} {$c ne "::oo::object"} {set c [$c __info superclass]} {
      foreach {methodName _ _ protection} [${c}::__ set procs] {
        if {$protection eq "private" && $c ne [::itcl::self]} continue
        if {[::info command [::itcl::self]::$methodName] ne ""} continue
        #puts "+++ c = $c, creating reflector for proc [::itcl::self] $methodName // $protection"
        namespace eval $c [list namespace export $methodName]
        namespace eval [::itcl::self] [list namespace import ${c}::$methodName]
      }
    }
  }
  
  class __method unknown {m args} {
    #puts "[::itcl::self]: unknown method '$m' args='$args' called"
    if {[string match *#auto* $m]} {
      set className [string tolower [namespace tail [::itcl::self]]]
      [::itcl::self]::__ __instvar auto
      while {1} {
        set new [string map [list #auto ${className}[incr auto]] $m]
        if {[::info command $new] eq ""} break
      }
      set m $new
    }
    eval [::itcl::self] create $m $args
  }

  object __method __self {} {::itcl::self}
  
  object init {
    method configure args {
      switch [llength $args] {
        0 { # list parameters with default values and current values
          return [lsort [::itcl::get_my_configure_values]]
        }
        1 { # list parameters with default values and current values
          return [lindex [::itcl::get_my_configure_values [string range [lindex $args 0] 1 end]] 0]
        }
        default {
          foreach {att value} $args {
            ::xotcl::setinstvar [::itcl::self] [string range $att 1 end] $value}
        }
      }
    }
    method isa className {
      ::xotcl::istype [::itcl::self] $className
    }
    method cget att {
      ::xotcl::setinstvar [::itcl::self] [string range $att 1 end]
    }
    method info args {
      #puts stderr "INFO $args [llength $args] [::info level]"
      
      if {[llength $args] == 0} {
        error {wrong # args: should be one of...
  info args procname
  info body procname
  info class
  info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body?
  info heritage
  info inherit
  info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?
...and others described on the man page}
      }
      if {[catch {set callingclass [::itcl::my __info class]}]} {
        set callingclass [uplevel namespace current]
      }
      switch -exact -- [lindex $args 0] {
        variable {
          ::itcl::get_my_variables $callingclass [lindex $args 1]
        }
      }
    }

    method move {new} {
      if {$new eq ""} {::itcl::my destroy} else {error "can't move [::itcl::self] to $new"}
    }
    constructor args {}
    destructor {
      #puts "destroying: [::itcl::my __info class] dealloc [::itcl::self]"
      if {[::xotcl::istype [::itcl::self] ::itcl::class]} {
        foreach i [::itcl::my __info instances] {$i destroy}
      }
      [::itcl::my __info class] dealloc [::itcl::self]
    }
  }
  

  # finally, define ::itcl::* procs with some helpers
  # 
  proc delete {what args} {foreach obj $args {$obj destroy}; return ""}
  proc find {what args} {
    set pattern [lindex $args end]
    set class ::itcl::object
    if {[llength $args] == 3} {
      if {[lindex $args 0] eq "-class"} {set class [lindex $args 1]}
    }
    set filter [expr {[string match "class*" $what] ? "::itcl::class" : "::itcl::object"}]
    set result [list]
    foreach c [::info command $pattern] {
      if {[::xotcl::istype $c $filter] && [::xotcl::istype $c $class]} {
        lappend result [string trimleft $c ::]
      }
    }
    return $result
  }
  proc is {what name} {::xotcl::istype $name ::itcl::$what}
  proc code {args} {
    switch [llength $args] {
      1 {[lindex $args end] __self}
      2 {if {[lindex $args 0] == "--"} {[lindex $args end] __self}}
    }
  }

  array set signature {
    ::itcl::object::cget -option
    ::itcl::object::configure "?-option? ?value -option value...?"
  }
  proc get_my_methods {currentclass callingclass} {
    set result ""
    for {set c $currentclass} {$c ne "::oo::object"} {set c [$c __info superclass]} {
      foreach {methodName _ _ protection} [${c}::__ set methods] {
        if {$protection eq "private"} {
          if {$c ne $currentclass && [::info command ${currentclass}::$methodName] ne ""} continue
          if {$c ne $callingclass} continue
        }
        if {$protection eq "protected" && [called_from_outside $callingclass $c $methodName]} continue
        switch -exact -- $methodName {
          info - move - destroy - constructor continue
        }
        #puts "... add $methodName"
        if {[::info exists ::itcl::signature(${c}::$methodName)]} {
          set args $::itcl::signature(${c}::$methodName)
        } else {
          set args [$c __info instargs $methodName]
          if {$args eq "args"} {set args "?arg arg ...?"}
        }
        append result "  [string trimleft [::itcl::self] :] $methodName[string trimright \ $args]\n"
      }
    }
    return [join [lsort -unique [split $result \n]] \n]
  }

  proc get_my_configure_values {{param *}} {
    set result [list]
    for {set c [::itcl::my __info class]} {$c ne "::itcl::object"} {set c [$c __info superclass]} {
      foreach v [${c}::__ set instvars] {
        set p [lindex $v 0]
        if {$param ne "*" && $param ne $p} continue
        if {[lindex $v end] ne "public"} continue
        lappend result [list -$p [lindex $v 1] [::xotcl::setinstvar [::itcl::self] $p]]
      }
    }
    return [lsort $result]
  }

  array set vartypes {classvars common privclassvars common instvars variable privinstvars variable}
  proc get_my_variables {callingclass {varname ""}} {
    #puts "get_my_variables: callingclass = $callingclass, varname=$varname"
    if {$varname eq ""} {
      # get all variables
      set result [list ${callingclass}::this]
      for {set c $callingclass} {$c ne "::itcl::object"} {set c [$c __info superclass]} {
        foreach kind {instvars privinstvars classvars privclassvars} {
          foreach v [${c}::__ set $kind] {
            lappend result ${c}::[lindex $v 0]
          }
        }
      }
    } else {
      for {set c $callingclass} {$c ne "::itcl::object"} {set c [$c __info superclass]} {
        foreach kind {instvars privinstvars classvars privclassvars} {
          foreach v [${c}::__ set $kind] {
            set p [lindex $v 0]
            if {$p eq $varname} {
              #puts "found $p in $kind // $v"
              set info [list [lindex $v end] $::itcl::vartypes($kind) ${c}::$p [lindex $v 1]]
              switch $kind {
                classvars     {lappend info [::xotcl::setinstvar $c $p]}
                privclassvars {lappend info [::xotcl::setinstvar $c $p]}
                instvars      -
                privinstvars  {
                  if {[catch {set obj [::itcl::self]}]} {
                    error "cannot access object-specific info without an object context"
                  }
                  if {[lindex $v end] eq "public"} {lappend info [lindex $v 2]}
                  lappend info [::xotcl::setinstvar $obj $p]
                }
              }
              return $info
            }
          }
        }
      }
    }
    return $result
  }
 
  # finally, export a few commands
  namespace export class
}