# $Id: s.Persistence.xotcl 1.12 01/03/23 21:55:32+01:00 neumann@somewhere.wu-wien.ac.at $
package provide xotcl::store::persistence 0.8

package require xotcl::trace
package require xotcl::package
package require xotcl::mixinStrategy

@ @File {
  description {
    Persistent store for XOTcl objects with Eager and Lazy persistence.
    Take a look at "persistenceExample.xotcl" for exmaple of usage.
  }
}

@ Class PersistenceMgr {
  description {
    A persistent store requires a persistent manager. The persistent
    manager implements the Storage interface via storage mixin. With 
    the parameter "dbPackage" we can specify which storage will be used.
    The persistent manager than tries to load the package 
    "xotcl::${dbPackage}Storage". Default is Sdbm.

    Example:
    <@pre>
    PersistenceMgr pmgr -persistenceDir . -persistenceFile example-db
    </@pre>
  }
}

#
# base class for persistent managers -- just register corresponding 
# storage mixin and open DB
#
Class PersistenceMgr -parameter {
  {persistenceFile {[string trimleft [self] :]}}
  {persistenceDir .}
  {dbPackage Sdbm}
}

PersistenceMgr instproc init args {
  [self] instvar persistenceDir persistenceFile dbPackage
  package require xotcl::store::[string tolower ${dbPackage}]
  Storage=${dbPackage} [self]::store
  ::array set [self]::persistentObjs {}
  next
}

PersistenceMgr instproc destroy args {
  foreach obj [::array names [self]::persistentObjs] {
    $obj storeall
    $obj persistenceMgr ""
  }
  [self]::store close
  next
}
PersistenceMgr instproc assureOpenDb {} {
  if {![::info exists [self]::dbOpen]} {
    [self] instvar persistenceDir persistenceFile
    if {![file exists $persistenceDir]} {
      file mkdir $persistenceDir
    } elseif {![file isdirectory $persistenceDir]} {
      error "Persistence dir is no directory!"
    } 
    #puts stderr "*** [self]::store open $persistenceDir/$persistenceFile.db"
    [self]::store open $persistenceDir/$persistenceFile.db
    ::set [self]::dbOpen 1
  }
}
PersistenceMgr instproc addPersistentObj {obj} {
  ::set [self]::persistentObjs($obj) ""
}
PersistenceMgr instproc removePersistentObj {obj} {
  if {[::info exists [self]::persistentObjs($obj)]} {
    ::unset [self]::persistentObjs($obj)
  }
}

@ Class Persistent {
  description {
    Superclass or mixin class for all persistent objects. Normally
    subclasses are used as mixins or instmixins on object, like:
    <@pre>
      o mixin Persistent=Eager
      p mixin Persistent=Lazy
    </@pre>
  }
}
#
# Persistence (mixin) classes
#
Class Persistent -parameter {
  persistenceMgr
}

# can be overloaded by subclasses, that need a cleanup on 
# persistenceMgr->destroy (like Lazy)
Persistent instproc storeall {} {;}

@ Persistent instproc persistenceMgr {args "persistent manager name"} {
  description {
    Specify which persistence manager to use for [self] object, like:
    <@pre>
      o persistenceMgr pmgr
    </@pre>
    Each persistent object must have a persistence manager specified, 
    before vars can be made persistent.
  }
}

#
# turn off persistence with ... persistenceMgr "", but 
# persistent vars stay persistent
#
Persistent instproc persistenceMgr args {
  if {[llength $args] == 0} {
    return [::set [self]::[self proc]]
  } elseif {[llength $args] == 1} {
    set pmgr [lindex $args 0]
    if {$pmgr == "" && [[self] exists persistenceMgr]} {
      [[self] set persistenceMgr] removePersistentObj [self]
      [self] unset persistenceMgr
      return ""
    }
    $pmgr addPersistentObj [self]
    return [::set [self]::[self proc] $pmgr]
  } else {
    error "wrong # args: [self] [self proc] ?value?"
  }
}

@ Persistent instproc persistentVars {} {
  description {
    Returns list of persistent vars.
  }
}

Persistent instproc persistentVars {} {
  if {[[self] exists __persistentVars]} {
    return [[self] set __persistentVars]
  }
  return ""
}

@ Persistent instproc persistent {list "persistent variables" } {
  description {
    Make a list of object variables persistent. If a persistent
    DB exists, the values are read from this DB, overwriting the current value.
    E.g.:
    <@pre>
     o persistent {x y}
    </@pre>

  }
}

Persistent instproc persistent {list} {
  [self] instvar persistenceMgr
  if {![info exists persistenceMgr]} {return}
  set store ${persistenceMgr}::store

  $persistenceMgr assureOpenDb
  foreach var $list {
    lappend [self]::__persistentVars $var
    # try to refetch vars from db
    if {[$store exists [self]::${var}(_____arraynames)]} {
      #puts stderr array=[self]::${var}
      foreach i [$store set [self]::${var}(_____arraynames)]  {
	set [self]::${var}($i) [$store set [self]::${var}($i)]
      }
    } elseif {[$store exists [self]::$var]} {
      #puts stderr "---store=$store exists [self]::$var"
      #puts stderr "---set [self]::$var [$store set [self]::$var]"
      set [self]::$var [$store set [self]::$var]
    } elseif {[info exists [self]::$var]} {
      #
      # first store of the variable in persistent store
      if {[array exists [self]::$var]} {
	# this variable is an array
	#puts stderr array=[self]::$var
	set anames [array names [self]::$var]
	foreach n $anames {
	  $store set [self]::${var}($n) [set [self]::${var}($n)]
	}
	$store set [self]::${var}(_____arraynames) $anames
      } else {
	#puts stderr "+++set [self]::$var [$store set [self]::$var]"
	$store set [self]::$var [set [self]::$var]
      }
    } else {
      error "persistent: $var is not a variable on [self]"
    }
  }
}

@ Persistent instproc unPersistent {list "persistent variables" } {
  description {
    Make a list of object variables not persistent. 
  }
}

Persistent instproc unPersistent {list} {
  [self] instvar __persistentVars
  foreach v $list {
    set i [lsearch -exact $__persistentVars $v]
    set __persistentVars [lreplace $__persistentVars $i $i]
    catch {[set [self]::persistenceMgr]::store unset [self]::$v}
  }
}

@ Persistent instproc makeVarScript {} {
  description {
    Build a Tcl script of "set ..." statements reflecting the current situation in the database.
  }
}
Persistent instproc makeVarScript {} {
  set script ""
  foreach v [[self] persistentVars] {
    set n [self]::[namespace tail $v]
    append script "set $n \"[set $n]\"\n"
  }
  return [concat [next] $script]
}

Persistent instproc destroy args {
  if {[[self] exists persistenceMgr]} {
    [[self] set persistenceMgr] removePersistentObj [self]
    [self] unset persistenceMgr
  }
  next
  #[self] showMsg "Persistent object [self] destroyed."
}

@ Class Persistent=Eager {
  description {
    Eager persistence strategy. Store everything at the same moment to the database
  }
}
Class Persistent=Eager -superclass Persistent

Persistent=Eager instproc vartrace {name sub op} {
  #[self] showCall
  if {$op == "w"} {
    [self] instvar persistenceMgr
    if {![info exists persistenceMgr]} {return}
    set store ${persistenceMgr}::store

    set key [self]::[namespace tail $name]
    if {$sub == ""} {
      #puts stderr "+++VT: $store set $key [set $key]"
      $store set $key [set $key]
    } else {
      if {$sub != "_____arraynames"} {
	$store set ${key}($sub) [set ${key}($sub)]
	$store set ${key}(_____arraynames) [::array names ${key}]
      } else {
	error "With persistent arrays you may not use '_____arraynames' as index"
      }
    }
  }
}

Persistent=Eager instproc persistent {list} {
  #[self] showCall
  next
  foreach v $list {
    #puts stderr "***trace variable [self]::$v w [list [self] vartrace]"
    trace variable [self]::$v w [list [self] vartrace]
  }
}

Persistent=Eager instproc unPersistent {list} {
  foreach v $list {
    trace vdelete [self]::$v w [list [self] vartrace]
  }
  next
}

@ Class Persistent=Lazy {
  description {
    Lazy persistence strategy. Store everything on object destroy (or program termination.
  }
}

Class Persistent=Lazy -superclass Persistent
Persistent=Lazy instproc storeall {} {
  [self] instvar persistenceMgr
  if {![info exists persistenceMgr]} {return}
  set store ${persistenceMgr}::store

  foreach v [[self] persistentVars] {
    if {[array exists [self]::$v]} {
      set anames ""
      foreach sub [array names [self]::$v] {
        if {[info exists [self]::${v}($sub)]} {
          set key [self]::${v}($sub)
          $store set $key [set $key]
	  lappend anames $sub
        }
      }
      $store set [self]::${v}(_____arraynames) $anames      
    } else {
      if {[info exists [self]::$v]} {
        set key [self]::$v
        $store set $key [set $key]
      }
    }
  }
}

Persistent=Lazy instproc destroy args {
  [self] storeall
  next
}
