# tie_file.tcl --
#
# Data source: Files.
#
# Copyright (c) 2004 Andreas Kupries <[email protected]>
#
# 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.3 2005/08/16 06:06:30 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).
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
unset cache
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}]
} 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 {} {
set cvalid 0
unset cache
return
}
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
## Ready to go
::tie::register ::tie::std::file as file
package provide tie::std::file 1.0
