purse

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"
    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

Now 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.

Category Package