# $Id: s.ScriptCreator.xotcl 1.6 01/03/23 21:55:33+01:00 neumann@somewhere.wu-wien.ac.at $
package provide xotcl::scriptCreation::scriptCreator 0.8

Class ScriptCreator \
  -parameter {
    {excludedObjs {Object Class Class::Parameter}}
    {excludeNames ""}
    {dependencyChecking 1}
  }


#
# 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} {
	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 [[self] set excludeNames] $v] == -1} {
	    if {[$obj array exists $v]} {
		foreach name [$obj array names $v] {
		    set arr ${v}($name)
		    set value [$obj set $arr]
		    append script "$obj set $arr \"$value\"\n"
		}
	    } else {
		set value [$obj set $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 [[self] set 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 [[self] set 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]} {
      error "ScriptCreator: $name needs parent $n, neither appended nor excluded yet."
    }
  }
}

ScriptCreator instproc checkClass {obj class} {
  if {![[self] isExcluded $class] &&
      ![[self] isAppended $class]} {
    error "ScriptCreator: $obj depends on $class, neither appended nor excluded yet."
  }
}

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 :]
  [self] lappend appendedNames $n
}

ScriptCreator instproc makeScript args {
  [self] instvar dependencyChecking
  [self] set appendedNames ""
  set script ""
  foreach name $args {
    #puts stderr "Script Creator -- $name"
    if {![[self] isExcluded $name] && 
	![[self] isAppended $name]} {
      
      if {$dependencyChecking} {
	[self] checkParents $name
      }
      if {[Object isobject $name]} {
	set class [$name info class]
	if {$dependencyChecking} {
	  [self] checkClass $name $class
	}
	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} {
	    foreach c $sl {
	      [self] checkClass $name $c
	    }
	  }
	  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
}
