# $Id: ScriptCreator.xotcl,v 1.3 2000/05/19 15:52:40 neumann Exp $
package provide ScriptCreator 0.8

Class ScriptCreator \
  -parameter {
    {excludedObjs [list Object \
		     Class \
		     ScriptCreator \
		     Class::Parameter]}
    {excludeNames ""}
    {dependencyChecking 1}
    {appendedNames ""}
  }


#
# queries the excludedObjs variable whether a given object
# is already defined/predefined or not  
# -> a way to exclude classes/objs from saving
#
ScriptCreator instproc isExcluded {n} {
  [self] instvar excludedObjs
  #puts stderr "Checking Excluded: $n in $excludedObjs"
  if {[lsearch $excludedObjs [string trimleft $n :]] == -1 &&
      [lsearch $excludedObjs $n] == -1} {
    return 0
  } else {
    return 1
  }
}

ScriptCreator instproc appendExcluded {n} {
    [self] instvar excludedObjs
    lappend excludedObjs [string trimleft $n :]
}

#
# compare command for lsort  
#
ScriptCreator instproc namespaceDepth {a b} {
    set aCount 0
    set bCount 0
    for {set i 0} {$i < [string length $a]} {incr i} {
	if {[string index $a $i] == ":"} {
	    incr aCount
	}
    }
    for {set i 0} {$i < [string length $b]} {incr i} {
	if {[string index $b $i] == ":"} {
	    incr bCount
	}
    }
    if {$aCount == $bCount} {
	return 0
    } elseif {$aCount > $bCount} {
	return 1
    }
		   
    return -1
} 

#
# produces a script containing the current state of 
# the given obj
#
ScriptCreator instproc stateScript {obj} {
    set script ""
    foreach v [$obj info vars] {
	if {[lsearch [set [self]::excludeNames] $v] == -1} {
	    if {[array exists ${obj}::$v]} {
		foreach name [array names ${obj}::$v] {
		    set arr ${v}($name)
		    set value [$obj set $arr]
		    append script "$obj set $arr \"$value\"\n"
		}
	    } else {
		set value [set ${obj}::$v]
		append script "$obj set $v \"$value\"\n"
	    }
	}
    }
    return $script
}

#
# produces a script containing the procs of the given obj
#
ScriptCreator instproc procScript {obj} {
    set script ""
    foreach p [$obj info procs] {
	if {[lsearch [set [self]::excludeNames] $p] == -1} {
	    append script \
		"$obj proc $p \{[$obj info args $p]\} \{[$obj info body $p]\}\n"
	}
    }
    return $script
}

#
# produces a script containing the instprocs of the given class
#
ScriptCreator instproc instprocScript {cl} {
    set script ""
    foreach p [$cl info instprocs] {
	if {[lsearch [set [self]::excludeNames] $p] == -1} {
	    append script \
		"$cl instproc $p \{[$cl info instargs $p]\} \{[$cl info instbody $p]\}\n"
	}
    }
    return $script
}



#
# saves a script to a file
#
ScriptCreator instproc saveScript {filename script} {
  set f [open $filename w]
  puts $f $script
  close $f
}

#
# load a script from a file
#
ScriptCreator instproc loadScript {filename} {
  set f [open $filename r]
  set r [read $f]
  close $f
  return $r
}

#
# check parent obj/classes/namespaces of an object completly
#
ScriptCreator instproc checkParents {name} {
  set p ""

  set n $name
  while {[set np [namespace parent ::$n]] != "::"} {
    lappend p $np
    set n $np
  }    
  set p [lsort -command {[self] namespaceDepth} $p]

  foreach n $p {
    if {![[self] isExcluded $n] &&
	![[self] isAppended $n]} {
      return 0
    }
  }
  return 1
}

ScriptCreator instproc checkClass {obj class} {
  if {![[self] isExcluded $class] &&
      ![[self] isAppended $class]} {
    return 0
  }
  return 1
}

ScriptCreator instproc checkSuperclasses name {
  foreach c [$name info superclass] { 
    if {![[self] checkClass $name $c]} {
      return 0
    }
  }
  return 1
}

ScriptCreator instproc isAppended name {
  set n [string trimleft $name :]
  if {[lsearch [[self] set appendedNames] $n]!=-1} {
    return 1
  } else {
    return 0
  }
}

ScriptCreator instproc appendName name {
  set n [string trimleft $name :]
  lappend [self]::appendedNames $n
}

ScriptCreator instproc reset {} {
  [self] set appendedNames ""
}

ScriptCreator instproc makeScript args {
  [self] instvar dependencyChecking
  set script ""
  foreach name $args {
    #puts stderr "Script Creator -- $name"
    if {![[self] isExcluded $name] && 
	![[self] isAppended $name]} {
      
      if {$dependencyChecking} {
	if {![[self] checkParents $name]} {
	  error "ScriptCreator: for $name parent namespace is not appended nor excluded yet."
	}
      }
      if {[Object isobject $name]} {
	set class [$name info class]
	if {$dependencyChecking} {
	  if {![[self] checkClass $name $class]} {
	    error "ScriptCreator: for $name its class is not appended nor excluded yet."
	  }
	}
	if {[Object isclass $name]} {
	  # append the class
	  #puts stderr "Appending Class: $name"
	  append script "[$name info class] $name"
	  set sl [$name info superclass]
	  if {$dependencyChecking} {
	    if {![[self] checkSuperclasses $name]} {
	      error "ScriptCreator: for $name its superclasses are not appended nor excluded yet."
	    }
	  }
	  if {$sl != ""} {
	    append script " -superclass \{$sl\}\n"
	  } else {
	    append script "\n"
	  }
	  append script [[self] instprocScript $name]
	} else {
	  # append the obj
	  #puts stderr "Appending Object: $name"
	  append script "[$name info class] $name\n"
	}
	append script [[self] procScript $name]
      } else {
	append script "namespace eval $name \{\}\n"
	#puts stderr "Appending Namespace: $name"
      }
      [self] appendName $name
    }
  }
  return $script
}

ScriptCreator instproc getAllSubClasses cl {
  set result ""
  set sc [$cl info subclass]
  foreach c $sc {
    lappend result $c
    set result [concat $result [[self] getAllSubClasses $c]]
  }
  return $result
}

ScriptCreator instproc getAllInstances cl {
  set result ""
  # get all subclasses of this class
  set subclasses [[self] getAllSubClasses $cl]
  # now get the instances of every subclass
  foreach sc $subclasses {
    set result [concat $result [$sc info instances]]
  }
  set result [concat $result [$cl info instances]]
  return $result
}


ScriptCreator instproc makeScriptForAll args {
  set allObjs [[self] getAllInstances Object]
  set soleObjs ""
  #puts "All objects are: $allObjs"
  foreach o $allObjs {
    if {[Object isclass $o]} {
      lappend classes $o
      if {[Object ismetaclass $o]} {
	lappend metaclasses $o}
    } else {
      lappend soleObjs $o
    }
  }
  #puts "All classes are: $classes"
  #puts "All metaclasses are: $metaclasses"

  set script ""

  #
  # make class script in order
  #
  set cls ""
  foreach c $classes {
    if {![[self] isExcluded $c]} {lappend cls $c}
  }
  
  set deleted 1
  while {$deleted != 0} {
    set deleted 0
    set clsIndex 0
    foreach name $cls {
      if {[[self] checkParents $name] &&
	  [[self] checkClass $name [$name info class]] &&
	  [[self] checkSuperclasses $name]} {
	
	append script [[self] makeScript $name]
	incr deleted
	set cls [lreplace $cls $clsIndex $clsIndex]
	incr clsIndex -1
      }
      incr clsIndex
    }
  } 
  #puts "Not handled: $cls"

  #
  # append objects
  #

  set objs ""
  foreach o $soleObjs {
    if {![[self] isExcluded $o]} {lappend objs $o}
  }
  set deleted 1
  while {$deleted != 0} {
    set deleted 0
    set objIndex 0
    foreach name $objs {
      if {![[self] isExcluded $name] &&
	  [[self] checkParents $name] &&
	  [[self] checkClass $name [$name info class]]} {
	append script [[self] makeScript $name]
	incr deleted
	set objs [lreplace $cls $objIndex $objIndex]
	incr objIndex -1
      }
      incr objIndex
    }
  }
  #puts "Not handled: $objs"

  [self] reset

  return $script
}