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

## fehlt noch: filter, mixins, metadata, ass, assoption, etc
## beim recover Class's,Object's proc instproc vars nicht ueberschreiben
## filter dann anhaengen etc ...
## der Recovery Filter darf durch Object filter "" nicht gelöscht werden

#
# filter to ensure that recovering doesn't overwrite 
# existing objs/classes
#

Object instproc recoveryFilter args {
    ::set method [self calledproc] 

    switch -- $method {
	create {
	    # don't overwrite objects
	    if {![::Object isobject [lindex $args 0]]} {
		next
	    } else {
		# puts stderr "Recovery Filter: omitting [lindex $args 0]"
	    }
	}
	proc {
	    if {[lsearch [[self] info procs] [lindex $args 0]] == -1} {
		next
	    } else {
		# puts stderr "Recovery Filter: omitting proc [self]::[lindex $args 0]"
	    }	
	}
	instproc {
	    if {[lsearch [[self] info instprocs] [lindex $args 0]] == -1} {
		next
	    } else {
		# puts stderr "Recovery Filter: omitting instproc [self]::[lindex $args 0]"
	    }
	}
	set {
	    if {[lsearch [[self] info vars] [lindex $args 0]] == -1} {
		next
	    } else {
		# puts stderr "Recovery Filter: omitting var [self]::[lindex $args 0]"
	    }
	}
	default  {next}
    }
}

#
# remove filter from object
#
Object instproc filterremove f {
    ::set fl [[self] info filter]
    puts stderr "filterremove on [self] with $f; fullName: [[self] filtersearch $f]" 
    while {[::set index [lsearch $fl [[self] filtersearch $f]]] != -1} {
	::set fl [lreplace $fl $index $index]
    }
    [self] filter $fl
}

#
# remove mixin from object
#
Object instproc mixinremove m {
    puts stderr "mixinremove on [self] with $m" 
    ::set ml [[self] info mixins]
    while {[::set index [lsearch $ml $m]] != -1} {
	::set ml [lreplace $ml $index $index]
    }
    [self] mixin $ml
}

Class RecoveryPoint \
    -parameter {
	{appendedObjs ""} 
	{appendedCls ""} 
	{appendedNamespaces ""} 
	{withState 0}
	{appendToFile 0}
	{definedObjs [list Object \
		      Class \
		      Class::Parameter]}
	{excludeNames ""}
    }

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

RecoveryPoint instproc appendDefined {n} {
    [self] instvar definedObjs
    lappend definedObjs [string trimleft $n :]
}

#
# check whether an obj/cls/namespace is appended already
# append obj/cls/namespace 
#
foreach method {Obj Cl Namespace} {
    set r {
	[self] instvar {appended${method}s name}}
    set r [subst -nocommands -nobackslash $r]
    
    set s $r
    append s {
	if {[lsearch $name [string trimleft $n :]] == -1} {
	    return 0
	} else {
	    return 1
	}
    }

    RecoveryPoint instproc isAppended$method {n} $s

    append r {
	lappend name [string trimleft $n :]
    }
    RecoveryPoint instproc append$method {n} $r
}
   

#
# compare command for lsort  
#
RecoveryPoint 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
#
RecoveryPoint 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
#
RecoveryPoint 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
#
RecoveryPoint 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
}

#
# append parent obj/classes/namespaces of an object completly
#

RecoveryPoint instproc appendParents {name} {
    # puts stderr "Recovery -- appendParents $name "
    set p ""
    set script ""

    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 {[Object isobject $n]} {
	    if {[$n isclass]} {
		append script [[self] classScript $n]
	    } else {
		append script [[self] objectScript $n]
	    }
	} else {
	    if {![[self] isAppendedNamespace $n]} {
		append script "namespace eval $n \{\}\n"
		# puts stderr "Recovery -- Appending Namespace: $n"
		[self] appendedNamespace $n
	    }        
	}
    }
    return $script
}


#
# produces a script recovering the given obj with all children
# without state
#
RecoveryPoint instproc objectScript {obj} {
    # puts stderr "Recovery -- Object Script $obj"
    [self] instvar withState
    set script ""
    if {![[self] isDefined $obj] && 
	![[self] isAppendedObj $obj]} {
	# if the object's class is not yet appended => do it now
	set objClass [$obj info class]
	append script [[self] classScript $objClass]

	# append all parent namespaces
	append script [[self] appendParents $obj]

	# append the obj
	append script "$objClass $obj\n"
	append script [[self] procScript $obj]
	if {$withState == 1} {
	    append script [[self] stateScript $obj]
	}
	# puts stderr "Recovery -- Appending Object: $obj"
	[self] appendObj $obj

	# append its children
	foreach o [$obj info children] {
	    append script [[self] objectScript $o]
	}
    }
    return $script
}

#
# produces a script recovering the given class with all children
# without state
#
RecoveryPoint instproc classScript {cl} {
    # puts stderr "Recovery -- Class Script $cl"
    [self] instvar withState
    set script ""
    if {![[self] isDefined $cl] &&
	  ![[self] isAppendedCl $cl]} { 
	# if the class's meta-class is not yet appended => do it now
	set metaClass [$cl info class]
	append script [[self] classScript $metaClass]

	# append all parent namespaces
	append script [[self] appendParents $cl]

	# append the class
	append script "$metaClass $cl"

	set sl [$cl info superclass]
	if {$sl != ""} {
	    append script " -superclass \{$sl\}\n"
	} else {
	    append script "\n"
	}

	append script [[self] instprocScript $cl]
	append script [[self] procScript $cl]

	if {$withState == 1} {
	    append script [[self] stateScript $cl]
	}

	# puts stderr "Recovery -- Appending Class: $cl \n $script"
	[self] appendCl $cl

	# append children
	set children [$cl info children]
	set classChildren [$cl info classchildren]

	foreach c $children {
	    if {[lsearch $classChildren $c] != -1} {
		append script [[self] classScript $c]
	    } else {
		append script [[self] objectScript $c]
	    }
	}
    }
    return $script
}

#
# produces a script recovering the given class and all subclasses 
# with all their children and all instances
#
#
RecoveryPoint instproc hierarchyScript {cl} {
    set script [[self] classScript $cl]
    set sortedInstances \
	[lsort -command {[self] namespaceDepth} [$cl info instances]]

    foreach o $sortedInstances {
	append script [[self] objectScript $o]
    }

    foreach c [$cl info subclass] {
	append script [[self] hierarchyScript $c]
    }

    return $script
}

#
# saves a script to a file
#
RecoveryPoint instproc saveScript {filename script} {
    [self] instvar appendToFile
    if {$appendToFile} {
	set mode a
    } else {
	set mode w
    }
    set f [open $filename $mode]
    puts $f $script
    close $f
}

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

#
# produce methods to save/recover an object script to/from a file 
# with/without state/only state
#

foreach method {Object ObjectState ObjectWithState Class ClassWithState \
		Hierarchy HierarchyWithState} {
  
  set s {
    set [self]::withState }

  if {[regexp {(.*)WithState} $method _ m]} {
      set call $m
      append s "1"
  } else {
      set call $method
      append s "0"
  }

  scan $call %c l
  set ::low "[format %c [expr {$l + 32}]][string range $call 1 end]"

  append s {
    [self] appendedObjs ""
    [self] appendedCls ""
    [self] appendedNamespaces ""
  }
  append s "
    foreach a \$args \{"
  set r {      
      set script [[self] ${low}Script }
  set r [subst -nocommands -nobackslash $r]
  append s $r
  append s {$a] 
      [self] saveScript $filename $script}
  append s "
    \}
  "

  RecoveryPoint instproc save$method {filename args} $s
}

RecoveryPoint instproc recover {filename} {
    set r [[self] loadScript $filename]
    Object filterappend recoveryFilter
    # puts stderr "RecoveryFilter appended for $filename" 
    eval $r
    Object filterremove recoveryFilter
    # puts stderr "RecoveryFilter removed for $filename" 
    return
}