Index: library/lib/xotcl1.xotcl
===================================================================
diff -u
--- library/lib/xotcl1.xotcl	(revision 0)
+++ library/lib/xotcl1.xotcl	(revision 1961a3b409a34f36625d8b51a94533d49867f1f3)
@@ -0,0 +1,574 @@
+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
+
+  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
+
+  # note, we are using ::xotcl::infoError defined earlier
+  Object instforward info -onerror ::xotcl::infoError ::xotcl::objectInfo %1 {%@2 %self}
+  Class instforward 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]"
+  }
+
+  #
+  # 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?
+  #
+  #   => TODO: use "params" in serializer, and all other occurances
+  #
+  #  TODO: not yet emulated:
+  #
+  #    => info is (bzw. ::xotcl::is) replaces
+  #     isobject
+  #     isclass
+  #     ismetaclass
+  #     ismixin
+  #     istype
+  #
+  #    => method (should get pre- and postconditions via positional params)
+  #     proc
+  #     instproc
+  #
+  # TODO mark all absolete calls at least as deprecated in library
+  #
+  # TODO move unknown handler for Class into a library, make sure that
+  # regression test and library function use explicit "creates".
+  #
+
+  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}
+    .method instprocs   {o pattern:optional} {
+      if {[::info exists pattern]} {
+	::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted $pattern
+      } {
+	::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted
+      }
+    }
+    .method procs       {o pattern:optional} {
+      if {[::info exists pattern]} {
+	::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype scripted $pattern
+      } {
+	::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype scripted
+      }
+    }
+    .method parametercmd {o pattern:optional} {
+      if {[::info exists pattern]} {
+	::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype setter $pattern
+      } {
+	::xotcl::cmd::ObjectInfo::methods $o -defined -per-object -methodtype setter
+      }
+    }
+  }
+
+  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}
+    .method procs       {o pattern:optional} {
+      if {[::info exists pattern]} {
+        ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted $pattern
+      } {
+        ::xotcl::cmd::ObjectInfo::methods $o -defined -methodtype scripted
+      }
+    }
+
+    .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 compiled}
+      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 methods on classInfo as well to overload the default behavior
+  ::xotcl::alias classInfo methods objectInfo::methods
+
+  # emulation of isobject, ...
+  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 instforward 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
+  }
+  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
+  }
+  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
+}