# purse makes tcl arrays purse-istant
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"
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 purse flush at exit
for {set newex "::exit_[expr rand()]"} {[info commands $newex] != {}} {set newex "::exit_[expr rand()]"} {}
rename ::exit $newex
proc ::exit {} [subst {
#puts stderr "flush $control"
::purse::flush ::purse::$control
$newex
}]
}
# 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]
puts $cont($name) [array get arr]
} else {
# brand new purse - create the file
set cont($name) [open $file w]
}
# 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]
puts $cont($name) [array get arr]
}
}
# flush arrays matching glob
proc purse::flush {control {glob *}} {
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]
puts $cont($array) [array get arr]
}
}
namespace export -clear purse
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
}