# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*- # -- Tcl Module # @@ Meta Begin # Package tie::std::file 1.0.2 # Meta as::origin http://sf.net/projects/tcllib # Meta license BSD # Meta platform tcl # Meta require {Tcl 8.4} # Meta require snit # Meta require tie # @@ Meta End # ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS package require Tcl 8.4 package require snit package require tie # ACTIVESTATE TEAPOT-PKG END REQUIREMENTS # ACTIVESTATE TEAPOT-PKG BEGIN DECLARE package provide tie::std::file 1.0.2 # ACTIVESTATE TEAPOT-PKG END DECLARE # ACTIVESTATE TEAPOT-PKG END TM # tie_file.tcl -- # # Data source: Files. # # Copyright (c) 2004 Andreas Kupries # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tie_file.tcl,v 1.8 2006/09/19 23:36:18 andreas_kupries Exp $ # ### ### ### ######### ######### ######### ## Requisites package require snit package require tie # ### ### ### ######### ######### ######### ## Implementation snit::type ::tie::std::file { # ### ### ### ######### ######### ######### ## Notes ## This data source maintains an internal cache for higher ## efficiency, i.e. to avoid having to go out to the slow file. ## This cache is handled as follows ## ## - All write operations invalidate the cache and write directly ## to the file. ## ## - All read operations load from the file if the cache is ## invalid, and from the cache otherwise ## This scheme works well in the following situations: ## (a) The data source is created, and then only read from. ## (b) The data source is created, and then only written to. ## (c) The data source is created, read once, and then only ## written to. ## This scheme works badly if the data source is opened and then ## randomly read from and written to. The cache is useless, as it ## is continuously invalidated and reloaded. ## This no problem from this developers POV of view however. ## Consider the context. If you have this situation just tie the ## DS to an array A after creation. The tie framework operates on ## the DS in mode (c) and A becomes an explicit cache for the DS ## which is not invalidated by writing to it. IOW this covers ## exactly the situation the DS by itself is not working well for. # ### ### ### ######### ######### ######### ## Specials pragma -hastypemethods no pragma -hasinfo no pragma -simpledispatch yes # ### ### ### ######### ######### ######### ## API : Construction & Destruction constructor {thepath} { # Locate and open the journal file. set path [::file normalize $thepath] if {[::file exists $path]} { set chan [open $path {RDWR EXCL APPEND}] } else { set chan [open $path {RDWR EXCL CREAT APPEND}] } fconfigure $chan -buffering none -encoding utf-8 return } destructor { # Release the channel to the journal file, should it be open. if {$chan ne ""} {close $chan} return } # ### ### ### ######### ######### ######### ## API : Data source methods method get {} { if {![::file size $path]} {return {}} $self LoadJournal return [array get cache] } method set {dict} { puts $chan [list array set $dict] $self Invalidate return } method unset {{pattern *}} { puts $chan [list array unset $pattern] $self Invalidate return } method names {} { if {![::file size $path]} {return {}} $self LoadJournal return [array names cache] } method size {} { if {![::file size $path]} {return 0} $self LoadJournal return [array size cache] } method getv {index} { if {![::file size $path]} { return -code error "can't read \"$index\": no such variable" } $self LoadJournal return $cache($index) } method setv {index value} { puts $chan [list set $index $value] $self Invalidate return } method unsetv {index} { puts $chan [list unset $index] $self Invalidate return } # ### ### ### ######### ######### ######### ## Internal : Instance data variable chan {} ; # Channel to write the journal. variable path {} ; # Path to journal file. # Journal loading, and cache. variable count 0 ; # #Operations in the journal. variable cvalid 0 ; # Validity of the cache. variable cache -array {} ; # Cache for journal # Management of the cache: See notes at beginning. # ### ### ### ######### ######### ######### ## Internal: Loading from the journal. method LoadJournal {} { if {$cvalid} return $self Replay $self Compact return } method Replay {} { # Use a safe interp for the evaluation of the journal file. # (Empty safe for the hidden commands and the aliases we insert). # Called for !cvalid, implies cache does not exist set ip [interp create -safe] foreach c [$ip eval {info commands}] { if {$c eq "rename"} continue $ip eval [list rename $c {}] } $ip eval {rename rename {}} interp alias $ip set {} $self Set interp alias $ip unset {} $self Unset interp alias $ip array {} $self Array array set cache {} set count 0 $ip invokehidden -global source $path interp delete $ip set cvalid 1 return } method Compact {} { # Compact the journal #puts @@/2*$count/3*[array size temp]/=/[expr {2*$count >= 3*[array size temp]}] # ASSERT cvalid # do not compact <=> # 2*ops < 3*size <=> # ops < 3/2*size <=> # ops < 1.5*size if {(2*$count) < (3*[array size cache])} return ::file delete -force ${path}.new set new [open ${path}.new {RDWR EXCL CREAT APPEND}] fconfigure $new -buffering none -encoding utf-8 # Compress current contents into a single multi-key load operation. puts $new [list array set [array get cache]] if {$::tcl_platform(platform) eq "windows"} { # For windows the open channels prevent us from # overwriting the old file. We have to leave # attackers a (small) window of opportunity for # replacing the file with something they own :( close $chan close $new ::file rename -force ${path}.new $path set chan [open ${path} {RDWR EXCL APPEND}] fconfigure $chan -buffering none -encoding utf-8 } else { # Copy compacted journal over the existing one. ::file rename -force ${path}.new $path close $chan set chan $new } return } method Set {index value} { set cache($index) $value incr count return } method Unset {index} { unset cache($index) incr count return } method Array {cmd detail} { # syntax : set dict # ...... : unset pattern if {$cmd eq "set"} { array set cache $detail } elseif {$cmd eq "unset"} { array unset cache $detail } else { return -code error "Illegal command \"$cmd\"" } incr count return } method Invalidate {} { if {!$cvalid} return set cvalid 0 unset cache return } # ### ### ### ######### ######### ######### } # ### ### ### ######### ######### ######### ## Ready to go ::tie::register ::tie::std::file as file package provide tie::std::file 1.0.2