SEH A delta virtual filesystem.
This virtual filesystem is designed to be used with a versioning virtual filesystem stacked on top of it. As the versioning filesystem generates a new separate file for every file edit, this filesystem will invisibly generate and manage deltas of the separate versions to save space.
It is designed to be used with the procedures posted on the tdelta page, but you can substitute the delta technology of your choice simply by overloading the tdelta and tpatch procedures.
The code includes logic to keep the new file intact if its delta with the existing file turns out to be bigger, or if the two versions are so different that the expense of generating a delta seems unwarranted (i.e., it won't waste time generating deltas of two jpeg or zip file versions if they have almost no content in common).
# Usage: ::vfs::template::version::delta::Mount <existing directory> <intermediate virtual delta directory>
# ::vfs::template::version::Mount <intermediate virtual delta directory> ?-keep <number>? ?-project <project name list>? ?-time <time>? <virtual versioning directory>
package require vfs 1
namespace eval ::vfs::template::version::delta {}
proc ::vfs::template::version::delta::Mount {args} {
set volume {}
if {[lindex $args 0] == "-volume"} {set volume "-volume"}
set pathto [eval MountProcedure $args]
set path [lindex $pathto 0]
set to [lindex $pathto 1]
eval ::vfs::filesystem mount $volume \$to \[list ::vfs::template::version::delta::handler \$path\]
::vfs::RegisterMount $to [list ::vfs::template::version::delta::Unmount]
if {[trace info execution close] == {}} {
trace add execution close leave ::vfs::template::version::delta::CloseTrace
}
return $to
}
proc ::vfs::template::version::delta::Unmount {to} {
set to [file normalize $to]
set path [lindex [::vfs::filesystem info $to] end]
UnmountProcedure $path $to
::vfs::filesystem unmount $to
}
proc ::vfs::template::version::delta::CloseTrace {commandString code result op} {
set errorCode $::errorCode
set errorInfo $::errorInfo
set channelID [lindex $commandString 1]
if [regexp {::Close ([^ ]+?) } $errorInfo trash errorChannelID] {
if [string equal $channelID $errorChannelID] {
if {[lindex $errorCode 0] == "POSIX"} {
set pError [lindex $errorCode 1]
::vfs::filesystem posixerror $::vfs::posix($pError) ; return -code error $::vfs::posix($pError)
}
set message [lindex [split $errorInfo \n] 0]
error $message $errorInfo $errorCode
}
}
}
proc ::vfs::template::version::delta::handler {path cmd root relative actualpath args} {
switch -- $cmd {
access {
set mode [lindex $args 0]
set error [catch {Access $path $root $relative $actualpath $mode}]
if $error {::vfs::filesystem posixerror $::vfs::posix(EACCES) ; return -code error $::vfs::posix(EACCES)}
}
createdirectory {
CreateDirectory $path $root $relative $actualpath
}
deletefile {
DeleteFile $path $root $relative $actualpath
}
fileattributes {
set index [lindex $args 0]
set value [lindex $args 1]
array set attributes [FileAttributes $path $root $relative $actualpath]
if {$index == {}} {
return [lsort [array names attributes]]
}
set attribute [lindex [lsort [array names attributes]] $index]
if {$value == {}} {
return $attributes($attribute)
}
FileAttributesSet $path $root $relative $actualpath $attribute $value
}
matchindirectory {
set pattern [lindex $args 0]
set types [lindex $args 1]
return [MatchInDirectory $path $root $relative $actualpath $pattern $types]
} open {
set mode [lindex $args 0]
if {$mode == {}} {set mode r}
set permissions [lindex $args 1]
set channelID [Open $path $root $relative $actualpath $mode $permissions]
switch -glob -- $mode {
"" -
"r*" -
"w*" {
seek $channelID 0
}
"a*" {
seek $channelID 0 end
}
default {
::vfs::filesystem posixerror $::vfs::posix(EINVAL)
return -code error $::vfs::posix(EINVAL)
}
}
set result $channelID
lappend result [list ::vfs::template::version::delta::Close $channelID $path $root $relative $actualpath $mode]
return $result
}
removedirectory {
set recursive [lindex $args 0]
if !$recursive {
if {[MatchInDirectory $path $root $relative $actualpath * 0] != {}} {
::vfs::filesystem posixerror $::vfs::posix(EEXIST)
return -code error $::vfs::posix(EEXIST)
}
}
RemoveDirectory $path $root $relative $actualpath
}
stat {
return [Stat $path $root $relative $actualpath]
}
utime {
set atime [lindex $args 0]
set mtime [lindex $args 1]
Utime $path $root $relative $actualpath $atime $mtime
}
}
}
namespace eval ::vfs::template::version::delta {
proc MountProcedure {args} {
if {[lindex $args 0] == "-volume"} {
set args [lrange $args 1 end]
set to [lindex $args 1]
} else {
set to [file normalize [lindex $args 1]]
}
set path [file normalize [lindex $args 0]]
if [info exists ::vfs::_unmountCmd($to)] {::vfs::unmount $to}
file mkdir $path
array unset ::vfs::_unmountCmd $to
lappend pathto $path
lappend pathto $to
return $pathto
}
proc UnmountProcedure {path to} {
return
}
proc Access {path root relative actualpath mode} {
set modeString [::vfs::accessMode $mode]
if {$modeString == "F"} {set modeString RWX}
set modeString [split $modeString {}]
set fileName [lindex [glob -nocomplain -path [file join $path $relative] *] 0]
set fileString {}
if [file readable $fileName] {lappend fileString R}
if [file writable $fileName] {lappend fileString W}
if [file executable $fileName] {lappend fileString X}
foreach mS $modeString {
set errorMessage "not [string map {R readable W writable X executable} $mS]"
if {[lsearch $fileString $mS] == -1} {error $errorMessage}
}
}
proc CreateDirectory {path root relative actualpath} {
file mkdir [file join $path $relative]
}
proc DeleteFile {path root relative actualpath} {
set fileName [file join $path $relative]
set timeStamp [lindex [split $fileName \;] 1]
set targetFile [Reconstitute $fileName]
foreach referenceFile [glob -directory [file dirname $fileName] -nocomplain *vfs&delta$timeStamp] {
regsub {\;vfs&delta[0-9]*$} $referenceFile "" reconFile]
set f [open $referenceFile r]
fconfigure $f -translation binary
set signature [read $f]
close $f
tpatch $targetFile $signature $reconFile
file delete $referenceFile
}
close $targetFile
file delete $fileName
return
}
proc FileAttributes {path root relative actualpath} {
set fileName [lindex [glob -nocomplain -path [file join $path $relative] *] 0]
file attributes $fileName
}
proc FileAttributesSet {path root relative actualpath attribute value} {
set fileName [lindex [glob -nocomplain -path [file join $path $relative] *] 0]
file attributes $fileName $attribute $value
}
proc MatchInDirectory {path root relative actualpath pattern types} {
if [::vfs::matchDirectories $types] {lappend typeString d}
if [::vfs::matchFiles $types] {lappend typeString f}
set globList "[glob -directory [file join $path $relative] -nocomplain -types $typeString $pattern] [glob -directory [file join $path $relative] -nocomplain -types "$typeString hidden" $pattern]"
set pathLength [expr [string length $path] - 1]
set newGlobList {}
foreach gL $globList {
set gL [string replace $gL 0 $pathLength $root]
regsub {\;vfs&delta.*$} $gL "" gL
lappend newGlobList $gL
}
return $newGlobList
}
proc Open {path root relative actualpath mode permissions} {
set fileName [lindex [glob -nocomplain -path [file join $path $relative] *] 0]
set newFile 0
if ![file exists $fileName] {set newFile 1}
set fileName [file join $path $relative]
set channelID [Reconstitute $fileName]
if [string equal $channelID {}] {set channelID [open $fileName $mode] ; close $channelID ; set channelID [::vfs::memchan]}
if $newFile {catch {file attributes $fileName -permissions $permissions}}
return $channelID
}
proc Close {channelID path root relative actualpath mode} {
# Do not close the channel in the close callback!
# It will crash Tcl! Honest!
# The core will close the channel after you've taken what info you need from it.
# close $channelID
if {$mode == "r"} {return}
set fileName [file join $path $relative]
set f [open $fileName w]
fconfigure $f -translation binary
seek $f 0
fconfigure $channelID -translation binary
seek $channelID 0
fcopy $channelID $f
close $f
Delta $fileName
return
}
proc RemoveDirectory {path root relative actualpath} {
catch {file delete [file join $path $relative]}
}
proc Stat {path root relative actualpath} {
set fileName [lindex [glob -nocomplain -path [file join $path $relative] *] 0]
set endtag [lindex [split $fileName \;] end]
if {[string first "vfs&delta" $endtag] || [string equal "vfs&delta" $endtag]} {file stat $fileName fs ; return [array get fs]}
set f [open $fileName r]
fconfigure $f -translation binary
set copyinstructions [read $f]
array set fileStats [lindex $copyinstructions 3]
unset copyinstructions
close $f
set size $fileStats(size)
file stat $fileName fs
set fs(size) $size
return [array get fs]
}
proc Utime {path root relative actualpath atime mtime} {
set fileName [lindex [glob -nocomplain -path [file join $path $relative] *] 0]
file atime $fileName $atime
file mtime $fileName $mtime
}
proc Delta {filename} {
set fileRoot [lindex [split [file tail $filename] \;] 0]
set fileNames [glob -nocomplain -path [file join [file dirname $filename] $fileRoot] *]
set nonDeltas {}
foreach fn $fileNames {
set endtag [lindex [split $fn \;] end]
if ![string first "vfs&delta" $endtag] {continue}
lappend nonDeltas $fn
set atimes($fn) [file atime $fn]
}
if {[set deltaIndex [llength $nonDeltas]] < 2} {return}
set nonDeltas [lsort -dictionary $nonDeltas]
incr deltaIndex -1
set i 0
while {$i < $deltaIndex} {
set referenceFile [lindex $nonDeltas $i]
set targetFile [lindex $nonDeltas [incr i]]
set signature [tdelta $referenceFile $targetFile $::trsync::blockSize 1 1]
set targetTimeStamp [lindex [split $targetFile \;] 1]
file stat $referenceFile fileStats
set signatureSize [string length $signature]
if {$signatureSize > $fileStats(size)} {
set fileName $referenceFile\;vfs&delta
file rename $referenceFile $fileName
continue
}
array set fileStats [file attributes $referenceFile]
set fileName $referenceFile\;vfs&delta$targetTimeStamp
set f [open $fileName w]
fconfigure $f -translation binary
puts -nonewline $f $signature
close $f
file delete $referenceFile
catch {file attributes $fileName -readonly 0}
catch {file attributes $fileName -permissions rw-rw-rw-}
catch {file attributes $fileName -owner $fileStats(uid)}
catch {file attributes $fileName -group $fileStats(gid)}
catch {file mtime $fileName $fileStats(mtime)}
catch {file atime $fileName $fileStats(atime)}
foreach attr [array names fileStats] {
if [string first "-" $attr] {continue}
if ![string first "-permissions" $attr] {continue}
if ![string first "-readonly" $attr] {continue}
catch {file attributes $fileName $attr $fileStats($attr)}
}
catch {file attributes $fileName -permissions $fileStats(mode)}
catch {file attributes $fileName -readonly $fileStats(-readonly)}
}
foreach fn [array names atimes] {
file atime $fn $atimes($fn)
}
}
proc Reconstitute {fileName} {
if [file isfile $fileName] {return [open $fileName r]}
if [file isfile $fileName\;vfs&delta] {return [open $fileName\;vfs&delta r]}
set targetFile [lindex [glob -nocomplain -path $fileName *] 0]
if [string equal $targetFile {}] {return}
set fileStack {}
while {[string first "\;vfs&delta" $targetFile] > -1} {
if ![regexp {\;vfs&delta([0-9]+)$} $targetFile trash targetTime] {break}
set fileStack "[list $targetFile] $fileStack"
set targetFile [lindex [glob -directory [file dirname $fileName] *\;$targetTime*] 0]
set atimes($targetFile) [file atime $targetFile]
}
set targetFile [open $targetFile r]
foreach fs $fileStack {
set f [open $fs r]
fconfigure $f -translation binary
set copyInstructions [read $f]
close $f
set fileToConstruct [::vfs::memchan]
tpatch $targetFile $copyInstructions $fileToConstruct
catch {close $targetFile}
set targetFile $fileToConstruct
}
foreach fn [array names atimes] {
file atime $fn $atimes($fn)
}
fconfigure $targetFile -translation auto
seek $targetFile 0
return $targetFile
}
}
# end namespace eval ::vfs::template::version::delta