# $Id$

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

# documentation stub object -> just ignore 
# all documentations if xoDoc is not loaded
Object ::@
::@ proc unknown args {}

#Object instproc recreate args {
#  [self] cleanup
#  ::set cl [[self] info class]
#  ::set pcl [$cl info parameterclass]
#  $pcl searchDefaults [self]
#  if {![eval [self] initmethods $args]} {
#    eval [self] init $args
#  }
#  return [self]
#}

Class instproc parameters args {
  ::xotcl::deprecated parameters parameter
  ::eval [self] parameter $args
}
# provide some Tcl-commands as methods for every Object
Object instproc array {opt array args} {
  ::eval ::array $opt [self]::$array $args
}
Object instproc vwait {varName} {
  ::vwait [self]::$varName
}
Object instproc append {varName args} {
  ::eval ::append [self]::$varName $args
}
Object instproc lappend {varName args} {
  ::eval ::lappend [self]::$varName $args
}
Object instproc cset {vn arg} {
  if {![[self] exists $vn]} {
    [self] set $vn $arg
  }
}
# newChild creates a new child under the current object
Class instproc newChild args {
  ::set name [[self] autoname -instance [namespace tail [self]]]
  ::eval [self] create [self callingobject]::$name $args
}
# new creates a new global object
Class instproc new args {
  ::eval [self] create [[self] autoname -instance [self]] $args
}
# support for XOTcl specifica
Object instproc filterappend f {
  [self] filter [concat [[self] info filter] $f]
}
Object instproc mixinappend m {
  ::set mix [[self] info mixin]
  [self] mixin [::lappend mix $m]
}

Object proc getExitHandler {} {
  if {[[self] exists __exitHandler]} {
    return [[self] set __exitHandler]
  } else {
    return ""
  }
}
Object proc setExitHandler body {
  return [[self] set __exitHandler $body]
}
Object proc unsetExitHandler {} {
  [self] unset __exitHandler
}
Class::Parameter instproc values {param args} {
  set ci [[self] info instinvar]
  set valueTest {}
  foreach a $args {
    ::lappend valueTest "\[\[self\] set $param\] == [list $a]"
  }
  ::lappend ci [join $valueTest " || "]
  [self] instinvar $ci
}

Object instproc abstract {methtype methname arglist} {
  if {$methtype  != "proc" && $methtype != "instproc"} {
    error "invalid method type '$methtype', \
	must be either 'proc' or 'instproc'."
  }
  [self] $methtype $methname $arglist "
    if {\[self callingproc\] != \[self proc\] && 
	\[self callingobject\] != \[self\]} {
      error \"Abstract method $methname $arglist called\"
    }
  "
}

#
# copy/move implementation 
#
Class Object::CopyHandler -parameter {
  {nsList ""}
  {dest ""}
  objLength
}

Object::CopyHandler instproc makeNamespaceList {ns} {
  ::lappend [self]::nsList $ns
  foreach c [namespace children $ns] {
    [self] makeNamespaceList $c
  }
}

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
Object::CopyHandler instproc getNsDest {ns} {
  set tail [string range $ns [[self] set objLength] end]
  return ::[string trimleft [[self] set dest]$tail :]
}

Object::CopyHandler instproc copyNamespaces {} {
  foreach ns [[self] set nsList] {
    set nsDest [[self] getNsDest $ns]
    if {[[self] isobject $ns]} {
      # copy class information
      if {[[self] isclass $ns]} {
	set cl [[$ns info class] create $nsDest]
	# class object
	set obj $cl
	$cl superclass [$ns info superclass]
	$cl parameterclass [$ns info parameterclass]
	$cl parameter [$ns info parameter]
	$cl instinvar [$ns info instinvar]
	$cl filter [$ns info filter]
	[self] copyNSVarsAndCmds ::XOTclClasses::$ns ::XOTclClasses::$nsDest
      } else {
	# create obj
	set obj [[$ns info class] $nsDest]
      }
      # copy object -> may be a class obj
      $obj invar [$ns info invar]
      $obj check [$ns info check]
      $obj mixin [$ns info mixin]
      # set md [$ns info metadata]
      # $obj metadata add $md
      # foreach m $md { $obj metadata $m [$ns metadata $m] }
    } else {
      Namespace [[self] getNsDest $nsDest]
    }
    [self] copyNSVarsAndCmds $ns $nsDest
  }
}

Object::CopyHandler instproc copy {obj dest} {
  #puts stderr "[self] copy <$obj> <$dest>"
  [self] set objLength [string length $obj]
  [self] set dest $dest
  [self] makeNamespaceList $obj
  [self] copyNamespaces
}

Class xotcl::NoInit 
xotcl::NoInit instproc init args {;}


Object instproc copy newName {
  ::set ch [[self class]::CopyHandler create [[self class] autoname xotclCopyHandler]]
  $ch copy [self] $newName
  $ch destroy
}

Object instproc move newName {
  if {$newName != ""} {
    [self] copy $newName
  }
  [self] destroy
}

xotcl 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 proc mkindex {meta dir args} {
  ::xotcl::deprecated ::xotcl::mkindex package
  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 Class [Class info heritage]] {
    eval ::lappend meths [$cl info instcommands]
  }
  set old [pwd]
  cd $dir
  ::append idx "# Tcl autoload index file, "
  ::append idx "version 2.0\n"
  ::append idx "# xotcl additions generated with "
  ::append idx "\"::xotcl::mkindex [list $meta] "
  ::append idx "[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::load $obj "
	  ::append idx "\$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::load $obj "
	  ::append idx "\$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 "
	  ::append idx "\$dir/$file\"\n"
	}
      }
    }
    close $f
  }
  set t [open tclIndex a+]
  puts $t $idx nonewline
  close $t
  cd $old
  return "$oc objects, $mc methods"
}


xotcl proc check_library_path {} {
  global auto_path env
  #puts stderr "initial auto_path <$auto_path>"
  if {[info exists env(XOTCL)] && [file isdirectory $env(XOTCL)]} {
    set ::xotcl::lib $env(XOTCL)
  } else {
    set xl xotcl-$::xotcl::version
    foreach dir $auto_path {
      if {[string match *xotcl* $dir] && [file isdirectory $dir]} {
	set ::xotcl::lib $dir
        return 1
      }
    }
    # check for directories in the current directory, check whether
    # we are in the source directory
    if {[regexp {^(.*/xotcl[^/]*)/?.*$} [pwd] _ p] && 
	[file isdirectory $p/src] && 
	[file isdirectory $p/lib]} {
      set ::xotcl::lib $p/lib
      set success 1
    }

    if {![info exists success]} {
      # check on the auto path for child or neighbor = xotcl
      foreach d $auto_path {
	foreach x [list [file join $d $xl] [file join $d .. $xl]] {
	  #puts stderr "check $x"
	  if {[file isdirectory $x]} { 
	    set ::xotcl::lib $x
	    set success 1
	    break
	  }
	}
	if {[info exists success]} {break}
      }
    }

    if {![info exists success] && ![file isdirectory $::xotcl::lib]} {
      puts stderr "Cannot locate the XOTcl library on your system!"
      return 0
    }
  }
  #puts stderr "[info exists success] <$::xotcl::lib>"
  set auto_path [linsert $auto_path [expr {[llength $auto_path]-2}] $::xotcl::lib]
  #puts stderr "final auto_path <$auto_path>"
}

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

set ::xotcl::confdir ~/.xotcl
set ::xotcl::logdir $::xotcl::confdir/log