package provide xotcl::store::persistence 1.0 package require -exact xotcl::trace 1.0 package require -exact xotcl::package 1.0 package require -exact xotcl::mixinStrategy 1.0 package require -exact xotcl::store 1.0 package require XOTcl 1 namespace eval ::xotcl::store::persistence { namespace import ::xotcl::* @ @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 } } # # base class for persistent managers -- just register corresponding # storage mixin and open DB # Class PersistenceMgr -parameter { {fileName {[string trimleft [self] :]}} {dbPackage Sdbm} trace dirName } PersistenceMgr instproc init args { my instvar dbPackage package require xotcl::store::[string tolower $dbPackage] Storage=$dbPackage [self]::store $args foreach v {dirName fileName} { if {[my exists $v]} { [self]::store $v [my set $v] } } if {[my exists trace]} { [self]::store filter traceFilter } my array set persistentObjs {} next } # delegate methods to the store object PersistenceMgr instproc store args { eval [self]::store $args } PersistenceMgr instproc destroy args { foreach obj [my array names persistentObjs] { $obj storeall $obj persistenceMgr "" } [self]::store close next } PersistenceMgr instproc assureOpenDb {} { if {![my exists dbOpen]} { [self]::store dbOpen my set dbOpen 1 } } PersistenceMgr instproc addPersistentObj {obj} { my set persistentObjs($obj) "" } PersistenceMgr instproc removePersistentObj {obj} { if {[my exists persistentObjs($obj)]} { my unset 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 } } # # 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 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 [my set [self proc]] } elseif {[llength $args] == 1} { set pmgr [lindex $args 0] if {$pmgr eq "" && [my exists persistenceMgr]} { [my set persistenceMgr] removePersistentObj [self] my unset persistenceMgr return "" } $pmgr addPersistentObj [self] return [my set [self proc] $pmgr] } else { error "wrong # args: [self] [self proc] ?value?" } } @ Persistent instproc persistentVars {} { description { Returns list of persistent vars. } } Persistent instproc persistentVars {} { if {[my exists __persistentVars]} { return [my 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} } } Persistent instproc persistent {list} { my instvar persistenceMgr if {![info exists persistenceMgr]} {return} set store ${persistenceMgr}::store $persistenceMgr assureOpenDb foreach var $list { my lappend __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)] { my set ${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]>" my instvar $var #set name [$store set [self]::$var] #puts ***name*[set name]--$var set $var [$store set [self]::$var] } elseif {[my exists $var]} { # # first store of the variable in persistent store if {[my array exists $var]} { # this variable is an array #puts stderr array=[self]::$var set anames [my array names $var] foreach n $anames { $store set [self]::${var}($n) [my set ${var}($n)] } $store set [self]::${var}(_____arraynames) $anames } else { #puts stderr "+++set [self]::$var [$store set [self]::$var]" $store set [self]::$var [my set $var] } } else { error "persistent: $var is not a variable on [self]" } } } @ Persistent instproc persistent+init {list "persistent variables" } { description { Initialize all data in the list as empty strings, if they do not exist yet, and then make them persistent using the 'persistent' method } } Persistent instproc persistent+init {list} { foreach pd $list { if {![my exists $pd]} { my set $pd "" } } my persistent $list } @ Persistent instproc unPersistent {list "persistent variables" } { description { Make a list of object variables not persistent. } } Persistent instproc unPersistent {list} { my instvar __persistentVars set pMgr [my set persistenceMgr] foreach v $list { set i [lsearch -exact $__persistentVars $v] catch { set __persistentVars [lreplace $__persistentVars $i $i] ${pMgr}::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 [my persistentVars] { set vt [namespace tail $v] append script [list my set $vt [my set $vt]]\n } #set script [concat [next] $script] return $script } Persistent instproc destroy args { if {[my exists persistenceMgr]} { [my set persistenceMgr] removePersistentObj [self] my unset persistenceMgr } next #my 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 # # we use 'strange' argument names to avoid name clashes with given # variable names, when we have to instvar "[self] instvar $nametail" # Persistent=Eager instproc vartrace {__name_vartrace __sub_vartrace __op_vartrace} { #my showCall if {$__op_vartrace eq "w"} { my instvar persistenceMgr if {![info exists persistenceMgr]} {return} set store ${persistenceMgr}::store set nametail [namespace tail $__name_vartrace] set key [self]::$nametail if {$__sub_vartrace eq ""} { my instvar $nametail #puts stderr "+++VT: $store set $key [set $nametail]" $store set $key [set $nametail] } else { if {$__sub_vartrace ne "_____arraynames"} { my instvar "${nametail}($__sub_vartrace) subname" $store set ${key}($__sub_vartrace) $subname $store set ${key}(_____arraynames) [my array names $nametail] } else { error "With persistent arrays you may not use '_____arraynames' as index" } } } } Persistent=Eager instproc persistent {list} { #my showCall next foreach v $list { #puts stderr "***trace variable [self]::$v w [list my vartrace]" my trace variable $v w [list [self] vartrace] } } Persistent=Eager instproc unPersistent {list} { foreach v $list { my trace vdelete $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 {} { my instvar persistenceMgr if {![info exists persistenceMgr]} {return} set store ${persistenceMgr}::store foreach v [my persistentVars] { if {[my array exists $v]} { set anames "" foreach sub [my array names $v] { if {[my exists ${v}($sub)]} { set key [self]::${v}($sub) $store set $key [my set ${v}($sub)] lappend anames $sub } } $store set [self]::${v}(_____arraynames) $anames } else { if {[my exists $v]} { set key [self]::$v $store set $key [my set $v] } } } } Persistent=Lazy instproc destroy args { my storeall next } namespace export PersistenceMgr Persistent Persistent=Eager Persistent=Lazy } namespace import ::xotcl::store::persistence::*