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