CMCc: Purse provides simple-minded array persistence using variable traces and files.
# purse makes tcl arrays purse-istant
package provide Purse 0.1
namespace eval ::purse {}
# param - sets a purse's parameters
# dir - directory in which purses are stored (default [pwd])
proc ::purse::param {var val {control purse}} {
variable $control
upvar 0 $control cont
if {![info exists cont]} {
#::purse::purse $control $control
set cont() [dict create dir [pwd]]
}
if {$var == "dir"} {
file mkdir $val
}
dict set cont() $var $val
}
# purse - purses an array
proc ::purse::purse {array {control purse}} {
#puts stderr "purse $array $control"
#set array [namespace which -variable $array]
upvar $array arr
variable $control
upvar 0 $control cont
if {![info exists cont]} {
#::purse::purse $control $control
set cont() [dict create]
}
if {![dict exists $cont() dir]} {
param dir [pwd] $control
}
trace add variable arr read [list ::purse::r $control $array] ;# one shot load file
trace add variable arr array [list ::purse::r $control $array] ;# one shot load file
trace add variable arr write [list ::purse::w $control $array]
trace add variable arr unset [list ::purse::u $control $array]
# register a single purse flush at exit
set pfx ::exit_purse_[string map [list ":" ""] $control]_
if { [info commands ${pfx}*] eq "" } {
set newex ${pfx}[expr rand()]
rename ::exit $newex
proc ::exit {} [subst {
#puts stderr "flush $control"
::purse::flush * $control
$newex
}]
}
}
proc ::purse::restart { {glob ::*} {control purse}} {
variable $control
upvar 0 $control cont
if {![info exists cont]} {
#::purse::purse $control $control
set cont() [dict create]
}
if {![dict exists $cont() dir]} {
param dir [pwd] $control
}
set arrays [glob -directory [dict get $cont() dir] -nocomplain -tails $glob]
foreach array $arrays {
set nspace [namespace qualifiers $array]
if { $nspace ne "" } {
namespace eval $nspace {}
}
r $control $array $array
}
return $arrays
}
# initializes pursed array - one shot
proc ::purse::r {control name array args} {
upvar $array arr
variable $control
upvar 0 $control cont
trace remove variable arr read [list ::purse::r $control $name] ;# one shot load file
trace remove variable arr array [list ::purse::r $control $name] ;# one shot load file
trace remove variable arr write [list ::purse::w $control $name]
trace remove variable arr unset [list ::purse::u $control $name]
set file [file join [dict get $cont() dir] $name]
if {[file exists $file]} {
# if the purse exists, load its contents to array
set fd [open $file r+]
while {![eof $fd]} {
array set arr [gets $fd]
}
close $fd
set cont($name) [open $file w]
fconfigure $cont($name) -buffering line
puts $cont($name) [array get arr]
} else {
# brand new purse - create the file
set cont($name) [open $file w]
fconfigure $cont($name) -buffering line
}
# we no longer need a read trace
trace add variable arr write [list ::purse::w $control $name]
trace add variable arr unset [list ::purse::u $control $name]
}
# trace unset - writes an element to purse
proc ::purse::w {control name array el op} {
#puts stderr "write $control $name $array $el $op"
upvar $array arr
variable $control
upvar 0 $control cont
if {![info exists cont($name)]} {
r $control $name arr
}
set fd $cont($name)
array set junk [list $el $arr($el)]
puts $fd [array get junk]
}
# trace unset - unsets an element in a pursed array
proc ::purse::u {control name array el op} {
#puts stderr "unset $control $name $array $el $op"
upvar $array arr
variable $control
upvar 0 $control cont
if {![info exists cont($name)]} {
r $control $name arr
if {$el != "" && [info exists arr($el)]} {
unset arr($el) ;# we have recreated the element - recurse
}
return
}
set file [file join [dict get $cont() dir] $name]
if {$el == ""} {
# removing the entire array - destroy the purse
if {[file exists $file]} {
file remove $file
}
} else {
# removing an element - flush the purse
close $cont($name)
set cont($name) [open $file w]
fconfigure $cont($name) -buffering line
puts $cont($name) [array get arr]
}
}
# flush arrays matching glob
proc ::purse::flush {{glob *} {control purse}} {
variable $control
upvar 0 $control cont
foreach {array fd} [array get cont $glob] {
if {$array == ""} continue
upvar #0 $array arr
catch {close $cont($array)}
set file [file join [dict get $cont() dir] $array]
set cont($array) [open $file w]
fconfigure $cont($array) -buffering line
puts $cont($array) [array get arr]
}
}
namespace export -clear purseNow for some simple tests
if {[info script] == $argv0} {
purse::param dir [file join [pwd] .purse] ;# set the dir for purses
purse::purse x ;# purse the array x
puts "initial: [array get x]"
set x(1) [clock scan now]
set x(2) [clock scan now]
unset x(2)
puts "subsequent: [array get x]"
exit ;# flushes the purse'd arrays
}Note that by the nature of the implementation, [info exists] will report 0 on every element of the array until the array is loaded. We load lazily (although that would be easy to change) so it would make sense to perform an [array size] or similar to provoke loading, if you need to test existence on an element.
EF I modified slightly the original code so that: