package provide xotcl1 1.0
#######################################################
# Classical ::xotcl-1.*
#######################################################
namespace eval ::xotcl {
  #
  # Perform the basic setup of XOTcl 1.x. First, let us allocate the
  # basic classes of XOTcl. This call creates the classes
  # ::xotcl::Object and ::xotcl::Class and defines these as root class
  # of the object system and as root meta class.
  #
  ::xotcl::createobjectsystem ::xotcl::Object ::xotcl::Class

  # provide the standard command set for ::xotcl::Object
  foreach cmd [info command ::xotcl::cmd::Object::*] {
    ::xotcl::alias Object [namespace tail $cmd] $cmd
  }

  # provide some Tcl-commands as methods for ::xotcl::Object
  foreach cmd {array append eval incr lappend set subst unset trace} {
    ::xotcl::alias Object $cmd -objscope ::$cmd
  }

  # provide the standard command set for ::xotcl::Class
  foreach cmd [info command ::xotcl::cmd::Class::*] {
    ::xotcl::alias Class [namespace tail $cmd] $cmd
  }

  # protect some methods against redefinition
  ::xotcl::methodproperty Object destroy static true
  ::xotcl::methodproperty Class  alloc   static true
  ::xotcl::methodproperty Class  dealloc static true
  ::xotcl::methodproperty Class  create  static true

  Class method unknown {args} {
    #puts stderr "use '[self] create $args', not '[self] $args'"
    eval my create $args
  }

  Object method unknown {m args} {
    if {![self isnext]} {
      error "[self]: unable to dispatch method '$m'"
    }
  }

  # "init" must exist on Object. per default it is empty.
  Object method init args {}

  Object method self {} {::xotcl::self}

  #
  # object-parameter definition, backwards compatible
  #
  ::xotcl::Object method objectparameter {} {
    set parameterdefinitions [::xotcl::parametersFromSlots [self]]
    lappend parameterdefinitions args
    #puts stderr "*** parameter definition for [self]: $parameterdefinitions"
    return $parameterdefinitions
  }

  #
  # create class and object for nonpositional argument processing
  Class create ::xotcl::ParameterType
  foreach cmd [info command ::xotcl::cmd::ParameterType::*] {
    ::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd
  }
  # register type boolean as checker for "switch"
  ::xotcl::alias ::xotcl::ParameterType type=switch ::xotcl::cmd::ParameterType::type=boolean
  # create an object for dispatching
  ::xotcl::ParameterType create ::xotcl::parameterType

  #
  # TODO:
  # - are createBootstrapAttributeSlots for ::xotcl::Class still needed?
  # - Defaults for objectparameter seem more natural.
  # - no definition yet for xotcl2::Class
  #
  
  # We provide a default value for superclass (when no superclass is specified explicitely)
  # for defining the top-level class of the object system, such that different
  # object systems might co-exist.
  
  createBootstrapAttributeSlots ::xotcl::Class {
    {__default_superclass ::xotcl::Object}
    {__default_metaclass ::xotcl::Class}
  }

  ::xotcl::register_system_slots ::xotcl

  ########################
  # Info definition
  ########################
  Object create ::xotcl::objectInfo
  Object create ::xotcl::classInfo

  # note, we are using ::xotcl::infoError defined earlier
  Object forward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self}
  Class  forward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self}

  objectInfo method info {obj} {
    set methods [list]
    foreach m [::info commands ::xotcl::objectInfo::*] {
      set name [namespace tail $m]
      if {$name eq "unknown"} continue
      lappend methods $name
    }
    return "valid options are: [join [lsort $methods] {, }]"
  }
  objectInfo method unknown {method args} {
    error "[::xotcl::self] unknown info option \"$method\"; [.info info]"
  }

  classInfo method info {cl} {
    set methods [list]
    foreach m [::info commands ::xotcl::classInfo::*] {
      set name [namespace tail $m]
      if {$name eq "unknown"} continue
      lappend methods $name
    }
    return "valid options are: [join [lsort $methods] {, }]"
  }
  classInfo method unknown {method args} {
    error "[::xotcl::self] unknown info option \"$method\"; [.info info]"
  }

  foreach cmd [::info command ::xotcl::cmd::ObjectInfo::*] {
    set cmdName [namespace tail $cmd]
    if {$cmdName eq "method"} continue
    ::xotcl::alias ::xotcl::objectInfo $cmdName $cmd
    ::xotcl::alias ::xotcl::classInfo $cmdName $cmd
  }
  foreach cmd [::info command ::xotcl::cmd::ClassInfo::*] {
    ::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $cmd
  }
  ::xotcl::alias ::xotcl::objectInfo is ::xotcl::is
  ::xotcl::alias ::xotcl::classInfo is ::xotcl::is
  ::xotcl::alias ::xotcl::classInfo classparent ::xotcl::cmd::ObjectInfo::parent
  ::xotcl::alias ::xotcl::classInfo classchildren ::xotcl::cmd::ObjectInfo::children

  #
  # Backward compatibility info subcommands;
  #
  # TODO: should go finally into a library.
  #
  # Obsolete methods
  #
  #   already emulated:
  #
  #    => info params .... replaces
  #     info args
  #     info nonposargs
  #     info default
  #
  #    => info instparams .... replaces
  #     info instargs
  #     info instnonposargs
  #     info instdefault
  #
  #    => maybe instead of "info params" and "info instparams"
  #     info params ?-per-object?
  #
  #    => info method .... replaces
  #     info body
  #     info instbody
  #
  #    => info methods .... replaces
  #     info commands
  #     info instcommands
  #     info procs
  #     info instprocs
  #     info parametercmd
  #     info instparametercmd
  #
  #    => info is (resp. ::xotcl::is) replaces
  #     info isobject
  #     info isclass
  #     info ismetaclass
  #     info ismixin
  #     info istype
  #
  #    => method .... replaces
  #     proc
  #     instproc
  #
  #   => TODO: use "params" in serializer, and all other occurances
  #
  #
  # TODO mark all absolete calls at least as deprecated in library
  #
  # TODO move unknown handler for Class into a library
  #

  proc ::xotcl::info_args {inst o method} {
  set result [list]
  foreach \
      argName [::xotcl::classInfo ${inst}params $o $method -varNames] \
      flag    [::xotcl::classInfo ${inst}params $o $method] {
	if {[string match -* $flag]} continue
	lappend result $argName
      }
    #puts stderr "+++ get ${inst}args for $o $method => $result"
    return $result
  }

  proc ::xotcl::info_nonposargs {inst o method} {
    set result [list]
    foreach flag [::xotcl::classInfo ${inst}params $o $method] {
      if {![string match -* $flag]} continue
      lappend result $flag
    }
    #puts stderr "+++ get ${inst}nonposargs for $o $method => $result"
    return $result
  }
  proc ::xotcl::info_default {inst o method arg varName} {
    foreach \
        argName [::xotcl::classInfo ${inst}params $o $method -varNames] \
        flag    [::xotcl::classInfo ${inst}params $o $method] {
          if {$argName eq $arg} {
            upvar 3 $varName default
            if {[llength $flag] == 2} {
              set default [lindex $flag 1]
              #puts stderr "--- get ${inst}default for $o $method $arg => $default"
              return 1
            }
            #puts stderr "--- get ${inst}default for $o $method $arg fails"
            set default ""
            return 0
          }
        }
    error "procedure \"$method\" doesn't have an argument \"$varName\""
  }
  classInfo eval {
    .method instargs {o method} {::xotcl::info_args inst $o $method}
    .method args     {o method} {::xotcl::info_args "" $o $method}
    .method instnonposargs {o method} {::xotcl::info_nonposargs inst $o $method}
    .method nonposargs     {o method} {::xotcl::info_nonposargs "" $o $method}
    .method instdefault {o method arg var} {::xotcl::info_default inst $o $method $arg $var}
    .method default     {o method arg var} {::xotcl::info_default "" $o $method $arg $var}

    # info options emulated by "info method"
    .method instbody    {o methodName} {
      lindex [::xotcl::cmd::ObjectInfo::method $o definition $methodName] end
    }

    # info options emulated by "info methods"
    .method instcommands {o {pattern:optional ""}} {
      ::xotcl::cmd::ObjectInfo::methods $o -defined {*}$pattern
    }
    .method instprocs   {o {pattern:optional ""}} {
      ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted {*}$pattern
    }
    .method parametercmd {o {pattern:optional ""}} {
      ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype setter {*}$pattern
    }
    .method instparametercmd {o {pattern:optional ""}} {
      ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype setter {*}$pattern
    }
  }

  objectInfo eval {
    .method args        {o method} {::xotcl::info_args "" $o $method}
    .method nonposargs  {o method} {::xotcl::info_nonposargs "" $o $method}
    .method default     {o method arg var} {::xotcl::info_default "" $o $method $arg $var}

    # info options emulated by "info method"
    .method body        {o methodName} {
      lindex [::xotcl::cmd::ObjectInfo::method $o -per-object definition $methodName] end
    }

    # info options emulated by "info methods"
    .method commands    {o {pattern:optional ""}} {
      ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object {*}$pattern
    }
    .method procs       {o {pattern:optional ""}} {
      ::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype scripted {*}$pattern
    }
    .method methods {
      o -nocmds:switch -noprocs:switch -incontext:switch pattern:optional
    } {
      set methodtype all
      if {$nocmds} {set methodtype scripted}
      if {$noprocs} {if {$nocmds} {return ""}; set methodtype system}
      set cmd [list ::xotcl::cmd::ObjectInfo::methods $o -methodtype $methodtype]
      if {$incontext} {lappend cmd -incontext}
      if {[::info exists pattern]} {lappend cmd $pattern}
      eval $cmd
    }
  }
  # define info methods from objectInfo on classInfo as well
  ::xotcl::alias classInfo body     objectInfo::body
  ::xotcl::alias classInfo commands objectInfo::commands
  ::xotcl::alias classInfo methods  objectInfo::methods
  ::xotcl::alias classInfo procs    objectInfo::procs


  # emulation of isobject, isclass ...
  Object method isobject    {{object:substdefault "[self]"}} {::xotcl::is $object object}
  Object method isclass     {{class:substdefault  "[self]"}} {::xotcl::is $class class}
  Object method ismetaclass {{class:substdefault  "[self]"}} {::xotcl::is $class metaclass}
  Object method ismixin     {class}  {::xotcl::is [self] mixin $class}
  Object method istype      {class}  {::xotcl::is [self] type $class}

  ::xotcl::alias ::xotcl::Object contains ::xotcl::classes::xotcl2::Object::contains
  ::xotcl::Class forward slots %self contains \
      -object {%::xotcl::dispatch [::xotcl::self] -objscope ::subst [::xotcl::self]::slot}
  #
  # define proc and instproc in terms of method
  #
  Object method proc {name arglist body precondition:optional postcondition:optional} {
    set cmd [list my method $name $arglist $body]
    if {[info exists precondition]}  {lappend cmd -precondition  $precondition}
    if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}
    eval $cmd
  }
  Object forward parametercmd %self setter
  Class method proc {name arglist body precondition:optional postcondition:optional} {
    set cmd [list my method -per-object $name $arglist $body]
    if {[info exists precondition]}  {lappend cmd -precondition  $precondition}
    if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}
    eval $cmd
  }
  Class method instproc {name arglist body precondition:optional postcondition:optional} {
    set cmd [list my method $name $arglist $body]
    if {[info exists precondition]}  {lappend cmd -precondition  $precondition}
    if {[info exists postcondition]} {lappend cmd -postcondition $postcondition}
    eval $cmd
  }
  Class forward parametercmd %self setter -per-object
  Class forward instparametercmd %self setter

  # we are changing the the semantics from forward -> instforward
  ::xotcl::alias Class instforward ::xotcl::cmd::Class::forward
  ::xotcl::alias Class forward ::xotcl::cmd::Object::forward
  #Class method forward {name args} {
  #  ::xotcl::dispatch [self] ::xotcl::cmd::Class::forward -per-object $name {*}$args
  #}

  Object method abstract {methtype methname arglist} {
    if {$methtype ne "proc" && $methtype ne "instproc" && $methtype ne "method"} {
      error "invalid method type '$methtype', \
	must be either 'proc', 'instproc' or 'method'."
    }
    .$methtype $methname $arglist "
      if {!\[::xotcl::self isnextcall\]} {
        error \"Abstract method $methname $arglist called\"
      } else {::xotcl::next}
    "
  }

  # support for XOTcl 1.* specific convenience routines
  Object method hasclass cl {
    if {[::xotcl::is [self] mixin $cl]} {return 1}
    ::xotcl::is [self] type $cl
  }
  Class method allinstances {} {
    # TODO: mark it deprecated
    return [.info instances -closure]
  }

  # keep old object interface for xotcl 1.*
  Object method -per-object unsetExitHandler {} {::xotcl::unsetExitHandler $newbody}
  Object method -per-object setExitHandler   {newbody} {::xotcl::setExitHandler $newbody}
  Object method -per-object getExitHandler   {} {:xotcl::getExitHandler}

  # resue some definitions from ::xotcl2
  ::xotcl::alias ::xotcl::Object copy ::xotcl::classes::xotcl2::Object::copy
  ::xotcl::alias ::xotcl::Object move ::xotcl::classes::xotcl2::Object::move
  ::xotcl::alias ::xotcl::Object defaultmethod ::xotcl::classes::xotcl2::Object::defaultmethod

  ::xotcl::alias ::xotcl::Class __unknown -per-object ::xotcl2::Class::__unknown
  ::xotcl::alias ::xotcl::Class parameter ::xotcl::classes::xotcl2::Class::parameter

  proc myproc {args} {linsert $args 0 [::xotcl::self]}
  proc myvar  {var}  {.requireNamespace; return [::xotcl::self]::$var}

  Object create ::xotcl::config
  config method load {obj file} {
    source $file
    foreach i [array names ::auto_index [list $obj *proc *]] {
      set type [lindex $i 1]
      set meth [lindex $i 2]
      if {[$obj info ${type}s $meth] == {}} {
        $obj $type $meth auto $::auto_index($i)
      }
  }
  }
  
  config method mkindex {meta dir args} {
    set sp {[ 	]+}
    set st {^[ 	]*}
    set wd {([^ 	;]+)}
    foreach creator $meta {
      ::lappend cp $st$creator${sp}create$sp$wd
      ::lappend ap $st$creator$sp$wd
    }
    foreach methodkind {proc instproc} {
      ::lappend mp $st$wd${sp}($methodkind)$sp$wd
    }
    foreach cl [concat ::xotcl::Class [::xotcl::Class info heritage]] {
      eval ::lappend meths [$cl info instcommands]
    }
    set old [pwd]
    cd $dir
    ::append idx "# Tcl autoload index file, version 2.0\n"
    ::append idx "# xotcl additions generated with "
    ::append idx "\"::xotcl::config::mkindex [list $meta] [list $dir] $args\"\n"
    set oc 0
    set mc 0
    foreach file [eval glob -nocomplain -- $args] {
      if {[catch {set f [open $file]} msg]} then {
        catch {close $f}
        cd $old
        error $msg
      }
      while {[gets $f line] >= 0} {
        foreach c $cp {
          if {[regexp $c $line x obj]==1 &&
              [string index $obj 0]!={$}} then {
            ::incr oc
            ::append idx "set auto_index($obj) "
            ::append idx "\"::xotcl::config::load $obj \$dir/$file\"\n"
          }
        }
        foreach a $ap {
          if {[regexp $a $line x obj]==1 &&
              [string index $obj 0]!={$} &&
              [lsearch -exact $meths $obj]==-1} {
            ::incr oc
            ::append idx "set auto_index($obj) "
            ::append idx "\"::xotcl::config::load $obj \$dir/$file\"\n"
          }
        }
        foreach m $mp {
          if {[regexp $m $line x obj ty pr]==1 &&
              [string index $obj 0]!={$} &&
              [string index $pr 0]!={$}} then {
            ::incr mc
            ::append idx "set \{auto_index($obj "
            ::append idx "$ty $pr)\} \"source \$dir/$file\"\n"
          }
        }
      }
      close $f
    }
    set t [open tclIndex a+]
    puts $t $idx nonewline
    close $t
    cd $old
    return "$oc objects, $mc methods"
  }

  #
  # if cutTheArg not 0, it cut from upvar argsList
  #
  Object method extractConfigureArg {al name {cutTheArg 0}} {
    set value ""
    upvar $al argList
    set largs [llength $argList]
    for {set i 0} {$i < $largs} {incr i} {
      if {[lindex $argList $i] == $name && $i + 1 < $largs} {
        set startIndex $i
        set endIndex [expr {$i + 1}]
        while {$endIndex < $largs &&
               [string first - [lindex $argList $endIndex]] != 0} {
          lappend value [lindex $argList $endIndex]
          incr endIndex
        }
      }
    }
    if {[info exists startIndex] && $cutTheArg != 0} {
      set argList [lreplace $argList $startIndex [expr {$endIndex - 1}]]
    }
    return $value
  }

  Object create ::xotcl::rcs
  rcs method date string {
    lreplace [lreplace $string 0 0] end end
  }
  rcs method version string {
    lindex $string 2
  }

  #
  # package support
  #
  # puts this for the time being into xotcl 1.*
  #
  ::xotcl::Class method uses list {
    foreach package $list {
      ::xotcl::package import -into [::xotcl::self] $package
      puts stderr "*** using ${package}::* in [::xotcl::self]"
    }
  }
  ::xotcl2::Class create ::xotcl::package -superclass ::xotcl::Class -parameter {
    provide
    {version 1.0}
    {autoexport {}}
    {export {}}
  } {
    
    .method -per-object create {name args} {
      set nq [namespace qualifiers $name]
      if {$nq ne "" && ![namespace exists $nq]} {Object create $nq}
      next
    }

    .method -per-object  extend {name args} {
      .require $name
      eval $name configure $args
    }
    
    .method -per-object contains script {
      if {[.exists provide]} {
        package provide [set .provide] [set .version]
      } else {
        package provide [::xotcl::self] [set .version]
      }
      namespace eval [::xotcl::self] {namespace import ::xotcl::*}
      namespace eval [::xotcl::self] $script
      foreach e [set .export] {
        set nq [namespace qualifiers $e]
        if {$nq ne ""} {
          namespace eval [::xotcl::self]::$nq [list namespace export [namespace tail $e]]
        } else {
          namespace eval [::xotcl::self] [list namespace export $e]
        }
      }
      foreach e [set .autoexport] {
        namespace eval :: [list namespace import [::xotcl::self]::$e]
      }
    }
    
    .method -per-object unknown args {
      #puts stderr "unknown: package $args"
      eval [set .packagecmd] $args
    }
    
    .method -per-object verbose value {
      set .verbose $value
    }
    
    .method -per-object present args {
      if {$::tcl_version<8.3} {
        switch -exact -- [lindex $args 0] {
          -exact  {set pkg [lindex $args 1]}
          default {set pkg [lindex $args 0]}
        }
        if {[info exists .loaded($pkg)]} {
          return ${.loaded}($pkg)
        } else {
          error "not found"
        }
      } else {
        eval [set .packagecmd] present $args
      }
    }
    
    .method -per-object import {{-into ::} pkg} {
      .require $pkg
      namespace eval $into [subst -nocommands {
        #puts stderr "*** package import ${pkg}::* into [namespace current]"
        namespace import ${pkg}::*
      }]
      # import subclasses if any
      foreach e [$pkg export] {
        set nq [namespace qualifiers $e]
        if {$nq ne ""} {
          namespace eval $into$nq [list namespace import ${pkg}::$e]
        }
      }
    }
    
    .method -per-object require args {
      #puts "XOTCL package require $args, current=[namespace current]"
      set prevComponent ${.component}
      if {[catch {set v [eval package present $args]} msg]} {
        #puts stderr "we have to load $msg"
        switch -exact -- [lindex $args 0] {
          -exact  {set pkg [lindex $args 1]}
          default {set pkg [lindex $args 0]}
        }
        set .component $pkg
        lappend .uses($prevComponent) ${.component}
        set v [uplevel \#1 [set .packagecmd] require $args]
        if {$v ne "" && ${.verbose}} {
        set path [lindex [::package ifneeded $pkg $v] 1]
          puts "... $pkg $v loaded from '$path'"
          set .loaded($pkg) $v   ;# loaded stuff needed for Tcl 8.0
        }
      }
      set .component $prevComponent
      return $v
    }
    
    set .component .
    set .verbose 0
    set .packagecmd ::package
  }
  
  if {[info exists cmd]} {unset cmd}
  # finally, export contents defined for xotcl 1.*
  namespace export Object Class myproc myvar
}