# $Id: predefined.xotcl,v 1.12 2006/10/04 20:40:23 neumann Exp $
namespace eval ::xotcl {
  proc ::xotcl::setrelation args {
    puts stderr "::xotcl::setrelation is deprecated, use '::xotcl::relation $args' instead"
    uplevel ::xotcl::relation $args
  }

  # first we create the ::oo:: object system. Actually, we do not need it.
  namespace eval ::oo {}
  ::xotcl::createobjectsystem ::oo::object ::oo::class

  if {[info command ::oo::object] ne ""} {
    # When the system shuts down, destroy is called for every
    # available object. When ::xotcl::Object and ::xotcl::Class are
    # destroyed, there would be no means to delete other objects, when
    # "destroy" and "dealloc" are only defined on these
    # objects. So, we register these on ::oo::object and ::oo::class
    # for the time being, since these two classes are deleted last.
    #
    ::xotcl::alias ::oo::object destroy ::xotcl::cmd::Object::destroy
    ::xotcl::alias ::oo::class  dealloc ::xotcl::cmd::Class::dealloc

    #
    # Perform the basic setup of XOTcl. 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

#     foreach o {::xotcl::Object ::xotcl::Class} {
#       foreach r {object class metaclass} {
#         puts stderr "$o $r=[::xotcl::is $o $r]"
#       }
#     }

    #
    # createobjectsystem creates already the relation that Class has Object as
    # superclass. We could define this here as well.
    #
#     puts stderr sc(class)=[::xotcl::relation ::xotcl::Class superclass]
#     ::xotcl::relation ::xotcl::Class superclass ::xotcl::Object

    #
    # createobjectsystem creates already the relation that Object and
    # Class are instances of Class. We could define this here as well.
    #
#     puts stderr cl(object)=[::xotcl::relation ::xotcl::Object class]
#     puts stderr cl(class)=[::xotcl::relation ::xotcl::Class class]
#     ::xotcl::relation ::xotcl::Object class ::xotcl::Class
#     ::xotcl::relation ::xotcl::Class class ::xotcl::Class
  }
  
  #
  # By setting the variable bootstrap, we can check later, whether we
  # are in bootstrapping mode
  #
  set bootstrap 1

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

  # provide some Tcl-commands as methods for ::xotcl::Object
  foreach cmd {array append eval incr lappend trace subst unset} {
    ::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd
  }
  # provide the standard command set for ::xotcl::Class
  foreach cmd [info command ::xotcl::cmd::Class::*] {
    ::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd 
  }
  # "init" must exist on Object. per default it is empty.
  ::xotcl::Object instproc init args {}

  #
  # create class and object for nonpositional argument processing
  ::xotcl::Class create ::xotcl::NonposArgs
  foreach cmd [info command ::xotcl::cmd::NonposArgs::*] {
    ::xotcl::alias ::xotcl::NonposArgs [namespace tail $cmd] $cmd 
  }
  ::xotcl::NonposArgs create ::xotcl::nonposArgs 

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

  #foreach o {::xotcl::objectInfo ::xotcl::classInfo} {
  #  foreach r {object class metaclass} {
  #    puts stderr "$o $r=[::xotcl::is $o $r]"
  #  }
  #}
  foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] {
    ::xotcl::alias ::xotcl::objectInfo [namespace tail $cmd] $cmd 
    ::xotcl::alias ::xotcl::classInfo [namespace tail $cmd] $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
  unset cmd
  ::xotcl::Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self}
  ::xotcl::Class instforward info -onerror ::xotcl::infoError ::xotcl::classInfo %1 {%@2 %self}

  proc ::xotcl::infoError msg {
    #puts stderr "INFO ERROR: <$msg>\n$::errorInfo"
    regsub -all " <object>" $msg "" msg
    regsub -all " <class>" $msg "" msg
    regsub {\"} $msg "\"info " msg
    error $msg ""
  }
  ::xotcl::objectInfo proc 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] {, }]"
  }
  ::xotcl::objectInfo proc unknown {method args} {
    error "unknown info option \"$method\"; [my info info]"
  }

  ::xotcl::classInfo proc 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] {, }]"
  }
  ::xotcl::classInfo proc unknown {method args} {
    error "unknown info option \"$method\"; [my info info]"
  }

  # documentation stub object -> just ignore per default. 
  # if xoDoc is loaded, documentation will be activated
  ::xotcl::Object create ::xotcl::@

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

  namespace export Object Class @ myproc myvar Attribute

  ##################
  # Slot definitions
  ##################
  # still bootstrap code; we cannot use slots/-parameter yet
  ::xotcl::Class create ::xotcl::MetaSlot
  ::xotcl::relation ::xotcl::MetaSlot superclass ::xotcl::Class

  ::xotcl::MetaSlot instproc new args {
    set slotobject [::xotcl::self callingobject]::slot
    if {![::xotcl::is $slotobject object]} {::xotcl::Object create $slotobject}
    eval next -childof $slotobject $args
  }

  ::xotcl::MetaSlot create ::xotcl::Slot

  #foreach o {::xotcl::MetaSlot ::xotcl::Slot} {
  #  foreach r {object class metaclass} {
  #    puts stderr "$o $r=[::xotcl::is $o $r]"
  #  }
  #}

  # use low level interface for defining slot values. Normally, this is
  # done via slot objects, which are defined later. 
  
  proc createBootstrapAttributeSlots {class definitions} {
    if {![::xotcl::is ${class}::slot object]} {
      ::xotcl::Object create ${class}::slot
    }
    foreach att $definitions {
      if {[llength $att]>1} {foreach {att default} $att break}
      ::xotcl::Slot create ${class}::slot::$att
      if {[info exists default]} {
        ::xotcl::setinstvar ${class}::slot::$att default $default
        unset default
      }
      $class instparametercmd $att
    }
    # do a second round to ensure that the already defined objects
    # have the appropriate default values
    foreach att $definitions {
      if {[llength $att]>1} {foreach {att default} $att break}
      if {[info exists default]} {
        # checking subclasses is not required during bootstrap
        foreach i [$class info instances] {
          if {![$i exists $att]} {::xotcl::setinstvar $i $att $default}
        }
        unset default
      }
    }
  }
  
  # 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}
  }

  #
  # Define slots for slots
  #
  createBootstrapAttributeSlots ::xotcl::Slot {
    {name "[namespace tail [::xotcl::self]]"}
    {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]"}
    {defaultmethods {get assign}}
    {manager "[::xotcl::self]"}
    {multivalued false}
    {per-object false}
    {required false}
    default 
    type
  }
  # maybe add the following slots at some later time here
  #   initcmd
  #   valuecmd
  #   valuechangedcmd

  ::xotcl::alias ::xotcl::Slot get ::xotcl::setinstvar
  ::xotcl::alias ::xotcl::Slot assign ::xotcl::setinstvar

  ::xotcl::Slot instproc add {obj prop value {pos 0}} {
    if {![::xotcl::my multivalued]} {
      error "Property $prop of [::xotcl::my domain]->$obj ist not multivalued"
    }
    if {[$obj exists $prop]} {
      $obj set $prop [linsert [$obj set $prop] $pos $value]
    } else {
      $obj set $prop [list $value]
    }
  }
  ::xotcl::Slot instproc delete {-nocomplain:switch obj prop value} {
    set old [$obj set $prop]
    set p [lsearch -glob $old $value]
    if {$p>-1} {$obj set $prop [lreplace $old $p $p]} else {
      error "$value is not a $prop of $obj (valid are: $old)"
    }
  }

  ::xotcl::Slot instproc unknown {method args} {
    set methods [list]
    foreach m [::xotcl::my info methods] {
      if {[::xotcl::Object info methods $m] ne ""} continue
      if {[string match __* $m]} continue
      lappend methods $m
    }
    error "Method '$method' unknown for slot [::xotcl::self]; valid are: {[lsort $methods]]}"
  }
  ::xotcl::Slot instproc init {} {
    ::xotcl::my instvar name domain manager per-object
    set forwarder [expr {${per-object} ? "forward" : "instforward"}]
    #puts "domain=$domain /[::xotcl::self callingobject]/[::xotcl::my info parent]"
    if {$domain eq ""} {
      set domain [::xotcl::self callingobject]
    }
    $domain $forwarder $name -default [$manager defaultmethods] $manager %1 %self %proc
  }

  #
  #  InfoSlot
  #
  ::xotcl::MetaSlot create ::xotcl::InfoSlot 
  createBootstrapAttributeSlots ::xotcl::InfoSlot {
    {multivalued true}
    {elementtype ::xotcl::Class}
  }
  
  ::xotcl::relation ::xotcl::InfoSlot superclass ::xotcl::Slot
  ::xotcl::InfoSlot instproc get {obj prop} {$obj info $prop}
  ::xotcl::InfoSlot instproc add {obj prop value {pos 0}} {
    if {![::xotcl::my multivalued]} {
      error "Property $prop of [::xotcl::my domain]->$obj ist not multivalued"
    }
    $obj $prop [linsert [$obj info $prop] $pos $value]
  }
  ::xotcl::InfoSlot instproc delete {-nocomplain:switch obj prop value} {
    set old [$obj info $prop]
  if {[string first * $value] > -1 || [string first \[ $value] > -1} {
    # string contains meta characters
    if {[my elementtype] ne "" && ![string match ::* $value]} {
      # prefix string with ::, since all object names have leading ::
      set value ::$value
    }
    return [$obj $prop [lsearch -all -not -glob -inline $old $value]]
  } elseif {[my elementtype] ne ""} {
    if {[string first :: $value] == -1} {
      if {![my isobject $value]} {
        error "$value does not appear to be an object"
      }
      set value [$value self]
    }
    if {![$value isclass [my elementtype]]} {
      error "$value does not appear to be of type [my elementtype]"
    }
  }
  set p [lsearch -exact $old $value]
  if {$p > -1} {
    $obj $prop [lreplace $old $p $p]
  } else {
      error "$value is not a $prop of $obj (valid are: $old)"
    }
  }

  #
  # InterceptorSlot
  #
  ::xotcl::MetaSlot alloc ::xotcl::InterceptorSlot

  ::xotcl::relation ::xotcl::InterceptorSlot superclass ::xotcl::InfoSlot
  ::xotcl::alias ::xotcl::InterceptorSlot set ::xotcl::relation ;# for backwards compatibility
  ::xotcl::alias ::xotcl::InterceptorSlot assign ::xotcl::relation

  ::xotcl::InterceptorSlot instproc add {obj prop value {pos 0}} {
    if {![::xotcl::my multivalued]} {
      error "Property $prop of [::xotcl::my domain]->$obj ist not multivalued"
    }
    $obj $prop [linsert [$obj info $prop -guards] $pos $value]
  }

  ######################
  # system slots
  ######################
  #namespace eval ::xotcl::Class::slot {}
  namespace eval ::xotcl::Object::slot {}
  ::xotcl::Object alloc ::xotcl::Class::slot
  ::xotcl::Object alloc ::xotcl::Object::slot

  ::xotcl::InfoSlot create ::xotcl::Class::slot::superclass
  ::xotcl::alias ::xotcl::Class::slot::superclass assign ::xotcl::relation
  ::xotcl::InfoSlot create ::xotcl::Object::slot::class
  ::xotcl::alias ::xotcl::Object::slot::class assign ::xotcl::relation

  ::xotcl::InterceptorSlot create ::xotcl::Object::slot::mixin
::xotcl::InterceptorSlot create ::xotcl::Object::slot::filter -elementtype ""
  ::xotcl::InterceptorSlot create ::xotcl::Class::slot::instmixin
::xotcl::InterceptorSlot create ::xotcl::Class::slot::instfilter -elementtype ""

  #
  # Attribute
  #
  ::xotcl::MetaSlot create ::xotcl::Attribute -superclass ::xotcl::Slot

  createBootstrapAttributeSlots ::xotcl::Attribute {
    {value_check once}
    initcmd
    valuecmd
    valuechangedcmd
  }

  ::xotcl::Attribute instproc __default_from_cmd {obj cmd var sub op} {
    #puts "GETVAR [::xotcl::self proc] obj=$obj cmd=$cmd, var=$var, op=$op"
    $obj trace remove variable $var $op [list [::xotcl::self] [::xotcl::self proc] $obj $cmd]
    $obj set $var [$obj eval $cmd]
  }
  ::xotcl::Attribute instproc __value_from_cmd {obj cmd var sub op} {
    #puts "GETVAR [::xotcl::self proc] obj=$obj cmd=$cmd, var=$var, op=$op"
    $obj set $var [$obj eval $cmd]
  }
  ::xotcl::Attribute instproc __value_changed_cmd {obj cmd var sub op} {
    # puts stderr "**************************"
    # puts "valuechanged obj=$obj cmd=$cmd, var=$var, op=$op, ...\n$obj exists $var -> [$obj set $var]"
    eval $cmd
  }
  ::xotcl::Attribute instproc check_single_value {
    {-keep_old_value:boolean true}
    value predicate type obj var
  } {
    #puts "+++ checking single value '$value' with $predicate ==> [expr $predicate]"
    if {![expr $predicate]} {
      if {[$obj exists __oldvalue($var)]} {
        $obj set $var [$obj set __oldvalue($var)]
      } else {
        $obj unset -nocomplain $var
      }
      error "'$value' is not of type $type"
    }
    if {$keep_old_value} {$obj set __oldvalue($var) $value}
    #puts "+++ checking single value done"
  }

  ::xotcl::Attribute instproc check_multiple_values {values predicate type obj var} {
    foreach value $values {
      ::xotcl::my check_single_value -keep_old_value false $value $predicate $type $obj $var
    }
    $obj set __oldvalue($var) $value
  }
  ::xotcl::Attribute instproc mk_type_checker {} {
    set __initcmd ""
    if {[::xotcl::my exists type]} {
      ::xotcl::my instvar type name
      if {[::xotcl::Object isclass $type]} {
        set predicate [subst -nocommands {
          [::xotcl::Object isobject \$value] && [\$value istype $type]
        }]
      } elseif {[llength $type]>1} {
        set predicate "\[$type \$value\]"
      } else {
        #set predicate "\[string is $type \$value\]"
        set predicate "\[[self] type=$type $name \$value\]"
      }
      #puts stderr predicate=$predicate
      ::xotcl::my append valuechangedcmd [subst {
        ::xotcl::my [expr {[::xotcl::my multivalued] ? 
                           "check_multiple_values" : "check_single_value"
                         }] \[\$obj set $name\] \
            {$predicate} [list $type] \$obj $name
      }]
      append __initcmd [subst -nocommands {
        if {[::xotcl::my exists $name]} {::xotcl::my set __oldvalue($name) [::xotcl::my set $name]}\n
      }]
    }
    return $__initcmd
  }
  ::xotcl::Attribute instproc init {} {
    ::xotcl::my instvar domain name
    next ;# do first ordinary slot initialization
    # there might be already default values registered on the class
    set __initcmd ""
    if {[::xotcl::my exists default]} {
    } elseif [::xotcl::my exists initcmd] {
      append __initcmd "::xotcl::my trace add variable [list $name] read \
	\[list [::xotcl::self] __default_from_cmd \[::xotcl::self\] [list [::xotcl::my initcmd]]\]\n"
    } elseif [::xotcl::my exists valuecmd] {
      append __initcmd "::xotcl::my trace add variable [list $name] read \
	\[list [::xotcl::self] __value_from_cmd \[::xotcl::self\] [list [::xotcl::my valuecmd]]\]"
    }
    append __initcmd [::xotcl::my mk_type_checker]
    if {[::xotcl::my exists valuechangedcmd]} {
      append __initcmd "::xotcl::my trace add variable [list $name] write \
	\[list [::xotcl::self] __value_changed_cmd \[::xotcl::self\] [list [::xotcl::my valuechangedcmd]]\]"
    }
    if {$__initcmd ne ""} {
      my set initcmd $__initcmd
    }
  }

  # mixin class for decativating all checks
::xotcl::Class create ::xotcl::Slot::Nocheck \
      -instproc check_single_value args {;} -instproc check_multiple_values args {;} \
      -instproc mk_type_checker args {return ""}
  ::xotcl::Class create ::xotcl::Slot::Optimizer \
      -instproc proc args    {::xotcl::next; ::xotcl::my optimize} \
      -instproc forward args {::xotcl::next; ::xotcl::my optimize} \
      -instproc init args    {::xotcl::next; ::xotcl::my optimize} \
      -instproc optimize {} {
        if {[::xotcl::my multivalued]} return
        if {[::xotcl::my defaultmethods] ne {get assign}} return
        if {[::xotcl::my procsearch assign] ne "::xotcl::Slot instcmd assign"} return
        if {[::xotcl::my procsearch get]    ne "::xotcl::Slot instcmd get"} return
        set forwarder [expr {[::xotcl::my per-object] ? "parametercmd":"instparametercmd"}]
        #puts stderr "**** optimizing       [::xotcl::my domain] $forwarder [::xotcl::my name]"
        [::xotcl::my domain] $forwarder [::xotcl::my name]
      }
  # register the optimizer per default
  ::xotcl::Attribute instmixin add ::xotcl::Slot::Optimizer

  #
  # Create a mixin class to overload method "new", such it does not allocate
  # new objects in ::xotcl::*, but in the specified object (without
  # syntactic overhead).
  #
  ::xotcl::Class create ::xotcl::ScopedNew -superclass ::xotcl::Class
  createBootstrapAttributeSlots ::xotcl::ScopedNew {
    {withclass ::xotcl::Object}
    inobject
  }

  ::xotcl::ScopedNew instproc init {} {
    ::xotcl::my instproc new {-childof args} {
      [::xotcl::self class] instvar {inobject object} withclass
      if {![::xotcl::my isobject $object]} {
        $withclass create $object
      }
      eval ::xotcl::next -childof $object $args
    }
  }
  #
  # change the namespace to the specified object and create
  # objects there. This is a friendly notation for creating 
  # nested object structures. Optionally, creating new objects
  # in the specified scope can be turned off.
  #
  ::xotcl::Object instproc contains {
    {-withnew:boolean true} 
    -object 
    {-class ::xotcl::Object} 
    cmds} {
      if {![info exists object]} {set object [::xotcl::self]}
      if {![::xotcl::my isobject $object]} {$class create $object}
      $object requireNamespace
      if {$withnew} {
        set m [::xotcl::ScopedNew new \
                   -inobject $object -withclass $class -volatile]
        ::xotcl::Class instmixin add $m end
        namespace eval $object $cmds
        ::xotcl::Class instmixin delete $m
      } else {
        namespace eval $object $cmds
      }
    }
  ::xotcl::Class instforward slots %self contains \
      -object {%::xotcl::my subst [::xotcl::self]::slot}
  

  #
  # define parameter for backward compatibility and convenience
  #
  ::xotcl::Class instproc parameter arglist {
    if {![::xotcl::is [::xotcl::self]::slot object]} {
      ::xotcl::Object create [::xotcl::self]::slot
    }
    foreach arg $arglist {
      #puts "arg=$arg"
      set l [llength $arg]
      set name [lindex $arg 0]
      if {[string first : $name] > -1} {
        foreach {name type} [split $name :] break
        # TODO: comma list processing missing
        if {$type eq "required"} {
          set required 1
          unset type
        }
      }
      set cmd [list ::xotcl::Attribute create [::xotcl::self]::slot::$name]
      if {[info exists type]} {
        lappend cmd -type $type
        unset type
      }
      if {[info exists required]} {
        lappend cmd -required 1
        unset required
      }
      if {$l == 1} {
        eval $cmd
        #puts stderr "parameter without default -> $cmd"
      } elseif {$l == 2} {
        lappend cmd [list -default [lindex $arg 1]]
        #puts stderr "parameter with default -> $cmd"
        eval $cmd
      } elseif {$l == 3 && [lindex $arg 1] eq "-default"} {
        lappend cmd [list -default [lindex $arg 2]]
        eval $cmd
      } else {
        set paramstring [string range $arg [expr {[string length $name]+1}] end]
        #puts  stderr "remaining arg = '$paramstring'"
        if {[string match {[$\[]*} $paramstring]} {
          lappend cmd [list -default $paramstring]
          eval $cmd
          continue
        }
        
        set po ::xotcl::Class::Parameter
        puts stderr "deprecated parameter usage '$arg'; use '-slots {Attribute ...}' instead"
        
        set cl [::xotcl::self]
        $po set name $name
        $po set cl [::xotcl::self]
        ::eval $po configure [lrange $arg 1 end]
        
        if {[$po exists extra] || [$po exists setter] || 
            [$po exists getter] || [$po exists access]} {
          $po instvar extra setter getter access defaultParam
          if {![info exists extra]} {set extra ""}
          if {![info exists defaultParam]} {set defaultParam ""}
          if {![info exists setter]} {set setter set}
          if {![info exists getter]} {set getter set}
          if {![info exists access]} {set access ::xotcl::my}
          $cl instproc $name args "
         if {\[llength \$args] == 0} {
           return \[$access $getter $extra $name\]
         } else {
           return \[eval $access $setter $extra $name \$args $defaultParam \]
         }"
          foreach instvar {extra defaultParam setter getter access} {
            $po unset -nocomplain $instvar
          }
        } else {
          ::xotcl::my instparametercmd $name
        }
      }
    }
    [::xotcl::self]::slot set __parameter $arglist
  }


  #
  # utilities
  #
  ::xotcl::Object instproc self {} {::xotcl::self}
  ::xotcl::Object instproc defaultmethod {} {
    #if {"::" ne [::xotcl::my info parent] } {
    #  [::xotcl::my info parent] __next
    #}
    return [::xotcl::self]
  }
  
  # support for XOTcl specific convenience routines
  ::xotcl::Object instproc hasclass cl {
    if {[::xotcl::my ismixin $cl]} {return 1}
    ::xotcl::my istype $cl
  }
  ::xotcl::Class instproc allinstances {} {
  # TODO: mark it deprecated
  return [::xotcl::my info instances -closure]
  }

  # Exit Handler
  ::xotcl::Object proc unsetExitHandler {} {
    ::xotcl::Object proc __exitHandler {} {
      # clients should append exit handlers to this proc body
      ;
    }
  }
  # pre-defined as empty method
  ::xotcl::Object unsetExitHandler
  ::xotcl::Object proc setExitHandler {newbody} {
    ::xotcl::Object proc __exitHandler {} $newbody
  }
  ::xotcl::Object proc getExitHandler {} {
    ::xotcl::Object info body __exitHandler
  }
  # provide a global handler to avoid a proc on the global object.
  proc ::xotcl::__exitHandler {} {
    ::xotcl::Object __exitHandler
  }
  ::xotcl::Object instproc 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'."
    }
    ::xotcl::my $methtype $methname $arglist "
    if {!\[::xotcl::self isnextcall\]} {
      error \"Abstract method $methname $arglist called\"
    } else {::xotcl::next}
  "
  }

  #
  # copy/move implementation 
  #
  ::xotcl::Class create ::xotcl::Object::CopyHandler -parameter {
    {targetList ""}
    {dest ""}
    objLength
  }
  
  # targets are all namspaces and objs part-of the copied obj
  ::xotcl::Object::CopyHandler instproc makeTargetList t {
    ::xotcl::my lappend targetList $t
    # if it is an object without namespace, it is a leaf
    if {[::xotcl::my isobject $t]} {
      if {[$t info hasnamespace]} {
        # make target list from all children
        set children [$t info children]
      } else {
        # ok, no namespace -> no more children 
        return
      }
    }
    # now append all namespaces that are in the obj, but that
    # are not objects
    foreach c [namespace children $t] {
      if {![::xotcl::my isobject $c]} {
        lappend children [namespace children $t]
      }
    }
    
    # a namespace or an obj with namespace may have children
    # itself
    foreach c $children {
      ::xotcl::my makeTargetList $c
    }
  }
  
  ::xotcl::Object::CopyHandler instproc copyNSVarsAndCmds {orig dest} {
    ::xotcl::namespace_copyvars $orig $dest
    ::xotcl::namespace_copycmds $orig $dest
  }
  
  # construct destination obj name from old qualified ns name
  ::xotcl::Object::CopyHandler instproc getDest origin {
    set tail [string range $origin [::xotcl::my set objLength] end]
    return ::[string trimleft [::xotcl::my set dest]$tail :]
  }
  
  ::xotcl::Object::CopyHandler instproc copyTargets {} {
    #puts stderr "copy targetList = [::xotcl::my set targetList]"
    foreach origin [::xotcl::my set targetList] {
      set dest [::xotcl::my getDest $origin]
      if {[::xotcl::my isobject $origin]} {
        # copy class information
        if {[::xotcl::my isclass $origin]} {
          set cl [[$origin info class] create $dest -noinit]
          # class object
          set obj $cl
          $cl superclass [$origin info superclass]
          #$cl parameterclass [$origin info parameterclass]
          $cl instinvar [$origin info instinvar]
          $cl instfilter [$origin info instfilter -guards]
          $cl instmixin [$origin info instmixin]
	my copyNSVarsAndCmds ::xotcl::classes$origin ::xotcl::classes$dest
          #$cl parameter [$origin info parameter]
        } else {
          # create obj
          set obj [[$origin info class] create $dest -noinit]
        }
        # copy object -> may be a class obj
        $obj invar [$origin info invar]
        $obj check [$origin info check]
        $obj mixin [$origin info mixin]
        $obj filter [$origin info filter -guards]
        # set md [$origin info metadata]
        # $obj metadata add $md
        # foreach m $md { $obj metadata $m [$origin metadata $m] }
        if {[$origin info hasnamespace]} {
          $obj requireNamespace
        }
      } else {
        namespace eval $dest {}
      }
      ::xotcl::my copyNSVarsAndCmds $origin $dest
      foreach i [$origin info forward] {
        eval [concat $dest forward $i [$origin info forward -definition $i]]
      }
      if {[::xotcl::my isclass $origin]} {
        foreach i [$origin info instforward] {
          eval [concat $dest instforward $i [$origin info instforward -definition $i]]
        }
      }
      set traces [list]
      foreach var [$origin info vars] {
        set cmds [$origin trace info variable $var]
        if {$cmds ne ""} {
          foreach cmd $cmds {
            foreach {op def} $cmd break
          #$origin trace remove variable $var $op $def
            if {[lindex $def 0] eq $origin} {
              set def [concat $dest [lrange $def 1 end]]
            }
            $dest trace add variable $var $op $def
          }
        }
      }
    }
    # alter 'domain' and 'manager' in slot objects
    set origin [lindex [::xotcl::my set targetList] 0]
    if {[::xotcl::my isclass $origin]} {
      foreach oldslot [$origin info slots] {
        set newslot ${cl}::slot::[namespace tail $oldslot]
        if {[$oldslot domain] eq $origin}   {$newslot domain $cl}
        if {[$oldslot manager] eq $oldslot} {$newslot manager $newslot}
      }
    }
  }
  
  ::xotcl::Object::CopyHandler instproc copy {obj dest} {
    #puts stderr "[::xotcl::self] copy <$obj> <$dest>"
    ::xotcl::my set objLength [string length $obj]
    ::xotcl::my set dest $dest
    ::xotcl::my makeTargetList $obj
    ::xotcl::my copyTargets
  }
  
  #Class create ::xotcl::NoInit
  #::xotcl::NoInit instproc init args {;}
  
  
  ::xotcl::Object instproc copy newName {
    if {[string compare [string trimleft $newName :] [string trimleft [::xotcl::self] :]]} {
      [[::xotcl::self class]::CopyHandler new -volatile] copy [::xotcl::self] $newName
    }
  }
  
  ::xotcl::Object instproc move newName {
    if {[string trimleft $newName :] ne [string trimleft [::xotcl::self] :]} {
      if {$newName ne ""} {
        ::xotcl::my copy $newName
      }
      ### let all subclasses get the copied class as superclass
      if {[::xotcl::my isclass [::xotcl::self]] && $newName ne ""} {
        foreach subclass [::xotcl::my info subclass] {
          set scl [$subclass info superclass]
          if {[set index [lsearch -exact $scl [::xotcl::self]]] != -1} {
            set scl [lreplace $scl $index $index $newName]
            $subclass superclass $scl
          }
        }	     
      }
      ::xotcl::my destroy
    }
  }
  
  ::xotcl::Object create ::xotcl::config
  ::xotcl::config proc 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)
      }
    }
  }
  
  ::xotcl::config proc 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 method {proc instproc} {
      ::lappend mp $st$wd${sp}($method)$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
  # 
  ::xotcl::Object instproc 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
  }
  
  ::xotcl::Object create ::xotcl::rcs
  ::xotcl::rcs proc date string {
    lreplace [lreplace $string 0 0] end end
  } 
  ::xotcl::rcs proc version string {
    lindex $string 2
  } 
  
  # if HOME is not set, and ~ is resolved, Tcl chokes on that
  if {![info exists ::env(HOME)]} {set ::env(HOME) /root}
  set ::xotcl::confdir ~/.xotcl
  set ::xotcl::logdir $::xotcl::confdir/log
  
  ::xotcl::Class proc __unknown name {
    #unknown $name
  }
  
  #
  # package support
  #
  ::xotcl::Class instproc uses list {
    foreach package $list {
      ::xotcl::package import -into [::xotcl::self] $package
      puts stderr "*** using ${package}::* in [::xotcl::self]"
    }
  }
  ::xotcl::Class create ::xotcl::package -superclass ::xotcl::Class -parameter {
    provide 
    {version 1.0} 
    {autoexport {}}
    {export {}}
  }
  ::xotcl::package proc create {name args} {
    set nq [namespace qualifiers $name]
    if {$nq ne "" && ![namespace exists $nq]} {Object create $nq}
    next
  }
  ::xotcl::package proc extend {name args} {
    my require $name
    eval $name configure $args
  }
  ::xotcl::package instproc contains script {
    if {[my exists provide]} {
      package provide [my provide] [my version]
    } else {
      package provide [::xotcl::self] [::xotcl::my version]
    }
    namespace eval [::xotcl::self] {namespace import ::xotcl::*}
    namespace eval [::xotcl::self] $script
    foreach e [my 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 [my autoexport] { 
      namespace eval :: [list namespace import [::xotcl::self]::$e]
    }
  }
  ::xotcl::package configure \
      -set component . \
      -set verbose 0 \
      -set packagecmd ::package
  
  ::xotcl::package proc unknown args {
    #puts stderr "unknown: package $args"
    eval [my set packagecmd] $args
  }
  ::xotcl::package proc verbose value {
    my set verbose $value
  }
  ::xotcl::package proc present args {
    if {$::tcl_version<8.3} {
      my instvar loaded
      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 [my set packagecmd] present $args
    }
  }
  ::xotcl::package proc import {{-into ::} pkg} {
    my 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]
      }
    }
  }
  ::xotcl::package proc require args {
    #puts "XOTCL package require $args, current=[namespace current]"
    ::xotcl::my instvar component verbose uses loaded
    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 [my 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
  }
 

  #
  # define method method
  #
  ::xotcl::Object instproc method {name arguments body} {
    my proc name $arguments $body				  
  }
::xotcl::Class instproc method {-per-object:switch name arguments body} {
    if {${per-object}} {
      my proc $name $arguments $body       
    } else {
      my instproc $name $arguments $body  
    }
  }

  # return temp directory
  proc ::xotcl::tmpdir {} {
    foreach e [list TMPDIR TEMP TMP] {
      if {[info exists ::env($e)] \
              && [file isdirectory $::env($e)] \
              && [file writable $::env($e)]} {
        return $::env($e)
      }
    }
    if {$::tcl_platform(platform) eq "windows"} {
      foreach d [list "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"] {
        if {[file isdirectory $d] && [file writable $d]} {
          return $d
        }
      }
    }
    return /tmp
  }
 
  unset bootstrap
}