1# tie_file.tcl -- 2# 3# Data source: Files. 4# 5# Copyright (c) 2004 Andreas Kupries <andreas_kupries@users.sourceforge.net> 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: tie_file.tcl,v 1.11 2008/02/28 06:19:56 andreas_kupries Exp $ 11 12# ### ### ### ######### ######### ######### 13## Requisites 14 15package require snit 16package require tie 17 18# ### ### ### ######### ######### ######### 19## Implementation 20 21snit::type ::tie::std::file { 22 # ### ### ### ######### ######### ######### 23 ## Notes 24 25 ## This data source maintains an internal cache for higher 26 ## efficiency, i.e. to avoid having to go out to the slow file. 27 28 ## This cache is handled as follows 29 ## 30 ## - All write operations invalidate the cache and write directly 31 ## to the file. 32 ## 33 ## - All read operations load from the file if the cache is 34 ## invalid, and from the cache otherwise 35 36 ## This scheme works well in the following situations: 37 38 ## (a) The data source is created, and then only read from. 39 ## (b) The data source is created, and then only written to. 40 ## (c) The data source is created, read once, and then only 41 ## written to. 42 43 ## This scheme works badly if the data source is opened and then 44 ## randomly read from and written to. The cache is useless, as it 45 ## is continuously invalidated and reloaded. 46 47 ## This no problem from this developers POV of view however. 48 ## Consider the context. If you have this situation just tie the 49 ## DS to an array A after creation. The tie framework operates on 50 ## the DS in mode (c) and A becomes an explicit cache for the DS 51 ## which is not invalidated by writing to it. IOW this covers 52 ## exactly the situation the DS by itself is not working well for. 53 54 # ### ### ### ######### ######### ######### 55 ## Specials 56 57 pragma -hastypemethods no 58 pragma -hasinfo no 59 pragma -simpledispatch yes 60 61 # ### ### ### ######### ######### ######### 62 ## API : Construction & Destruction 63 64 constructor {thepath} { 65 # Locate and open the journal file. 66 67 set path [::file normalize $thepath] 68 if {[::file exists $path]} { 69 set chan [open $path {RDWR EXCL APPEND}] 70 } else { 71 set chan [open $path {RDWR EXCL CREAT APPEND}] 72 } 73 fconfigure $chan -buffering none -encoding utf-8 74 return 75 } 76 77 destructor { 78 # Release the channel to the journal file, should it be open. 79 if {$chan ne ""} {close $chan} 80 return 81 } 82 83 # ### ### ### ######### ######### ######### 84 ## API : Data source methods 85 86 method get {} { 87 if {![::file size $path]} {return {}} 88 $self LoadJournal 89 return [array get cache] 90 } 91 92 method set {dict} { 93 puts $chan [list array set $dict] 94 $self Invalidate 95 return 96 } 97 98 method unset {{pattern *}} { 99 puts $chan [list array unset $pattern] 100 $self Invalidate 101 return 102 } 103 104 method names {} { 105 if {![::file size $path]} {return {}} 106 $self LoadJournal 107 return [array names cache] 108 } 109 110 method size {} { 111 if {![::file size $path]} {return 0} 112 $self LoadJournal 113 return [array size cache] 114 } 115 116 method getv {index} { 117 if {![::file size $path]} { 118 return -code error "can't read \"$index\": no such variable" 119 } 120 $self LoadJournal 121 return $cache($index) 122 } 123 124 method setv {index value} { 125 puts $chan [list set $index $value] 126 $self Invalidate 127 return 128 } 129 130 method unsetv {index} { 131 puts $chan [list unset $index] 132 $self Invalidate 133 return 134 } 135 136 # ### ### ### ######### ######### ######### 137 ## Internal : Instance data 138 139 variable chan {} ; # Channel to write the journal. 140 variable path {} ; # Path to journal file. 141 142 # Journal loading, and cache. 143 144 variable count 0 ; # #Operations in the journal. 145 variable cvalid 0 ; # Validity of the cache. 146 variable cache -array {} ; # Cache for journal 147 148 # Management of the cache: See notes at beginning. 149 150 # ### ### ### ######### ######### ######### 151 ## Internal: Loading from the journal. 152 153 method LoadJournal {} { 154 if {$cvalid} return 155 $self Replay 156 $self Compact 157 return 158 } 159 160 method Replay {} { 161 # Use a safe interp for the evaluation of the journal file. 162 # (Empty safe for the hidden commands and the aliases we insert). 163 164 # Called for !cvalid, implies cache does not exist 165 166 set ip [interp create -safe] 167 foreach c [$ip eval {info commands}] { 168 if {$c eq "rename"} continue 169 $ip eval [list rename $c {}] 170 } 171 $ip eval {rename rename {}} 172 173 interp alias $ip set {} $self Set 174 interp alias $ip unset {} $self Unset 175 interp alias $ip array {} $self Array 176 177 array set cache {} 178 set count 0 179 180 set jchan [open $path r] 181 fconfigure $jchan -encoding utf-8 182 set data [read $jchan] 183 close $jchan 184 185 $ip eval $data 186 interp delete $ip 187 188 set cvalid 1 189 return 190 } 191 192 method Compact {} { 193 # Compact the journal 194 195 #puts @@/2*$count/3*[array size temp]/=/[expr {2*$count >= 3*[array size temp]}] 196 197 # ASSERT cvalid 198 199 # do not compact <=> 200 # 2*ops < 3*size <=> 201 # ops < 3/2*size <=> 202 # ops < 1.5*size 203 204 if {(2*$count) < (3*[array size cache])} return 205 206 ::file delete -force ${path}.new 207 set new [open ${path}.new {RDWR EXCL CREAT APPEND}] 208 fconfigure $new -buffering none -encoding utf-8 209 210 # Compress current contents into a single multi-key load operation. 211 puts $new [list array set [array get cache]] 212 213 if {$::tcl_platform(platform) eq "windows"} { 214 # For windows the open channels prevent us from 215 # overwriting the old file. We have to leave 216 # attackers a (small) window of opportunity for 217 # replacing the file with something they own :( 218 close $chan 219 close $new 220 ::file rename -force ${path}.new $path 221 set chan [open ${path} {RDWR EXCL APPEND}] 222 fconfigure $chan -buffering none -encoding utf-8 223 } else { 224 # Copy compacted journal over the existing one. 225 ::file rename -force ${path}.new $path 226 close $chan 227 set chan $new 228 } 229 return 230 } 231 232 method Set {index value} { 233 set cache($index) $value 234 incr count 235 return 236 } 237 238 method Unset {index} { 239 unset cache($index) 240 incr count 241 return 242 } 243 244 method Array {cmd detail} { 245 # syntax : set dict 246 # ...... : unset pattern 247 248 if {$cmd eq "set"} { 249 array set cache $detail 250 } elseif {$cmd eq "unset"} { 251 array unset cache $detail 252 } else { 253 return -code error "Illegal command \"$cmd\"" 254 } 255 incr count 256 return 257 } 258 259 method Invalidate {} { 260 if {!$cvalid} return 261 set cvalid 0 262 unset cache 263 return 264 } 265 266 # ### ### ### ######### ######### ######### 267} 268 269# ### ### ### ######### ######### ######### 270## Ready to go 271 272::tie::register ::tie::std::file as file 273package provide tie::std::file 1.0.4 274