# deltavfs.tcl --
 # 
 #        A delta virtual filesystem.
 #
 #        This virtual filesystem is designed to be used with the versioning virtual filesystem 
 #        at http://wiki.tcl.tk/11980 stacked on top if 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.
 #
 # Written by Stephen Huntley (stephen.huntley@alum.mit.edu)
 #
 # Install: This code requires that the template vfs (http://wiki.tcl.tk/11938) procedures have already
 # been sourced into the interpreter.  The procedures tpatch and tdelta provided by sourcing tdelta.tcl 
 # at http://wiki.tcl.tk/12803 must also be available.
 # 
 # Usage: Mount <existing directory> <delta directory to be used as existing directory by versioning vfs>
 #

 package require vfs 1

 namespace eval ::vfs::template::version::delta {}

 proc ::vfs::template::version::delta::Mount {args} {
        eval [info body ::vfs::template::Mount]
 }

 namespace eval ::vfs::template::version::delta {

 proc MountProcedure {args} {
        foreach templateProc "Mount Unmount CloseTrace handler" {
                set infoArgs [info args ::vfs::template::$templateProc]
                set infoBody [info body ::vfs::template::$templateProc]
                proc $templateProc $infoArgs $infoBody
        }

        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 fileNames [glob -nocomplain -path [file join $path $relative] *]
        if [catch {::vfs::filesystem info $path}] {append fileNames " [glob -nocomplain -path [file join $path $relative] -type hidden *]"}
        set fileName [lindex $fileNames 0]
        if [set i [expr [lsearch -exact $fileNames [file join $path $relative]] + 1]] {set fileName [lindex $fileNames [incr i -1]]}

        set modeString [::vfs::accessMode $mode]
        if {$modeString == "F"} {
                if [file exists $fileName] {return}
                error "no such file or directory"
        }
        set modeString [split $modeString {}]
        set fileString {}
        if {[string equal $modeString "R"] && [file readable $fileName]} {return}
        if {[string equal $modeString "W"] && [file writable $fileName]} {return}
        if {[string equal $modeString "X"] && [file executable $fileName]} {return}
        file stat $fileName stat
        foreach { mask pairs } {
                00400 { 00400 r }
                00200 { 00200 w }
                04100 { 04100 s 04000 S 00100 x }
                00040 { 00040 r }
                00020 { 00020 w }
                02010 { 02010 s 02000 S 00010 x }
                00004 { 00004 r }
                00002 { 00002 w }
                01001 { 01001 t 01000 T 00001 x }
            } {
                set value [expr $stat(mode) & $mask]
                set bit -
                foreach { x b } $pairs {
                    if { $value == $x } {
                        set bit $b
                    }
                }
                append bitString $bit
      }
        set readable [regexp -all "r" $bitString]
        set writable [regexp -all "w" $bitString]
        set executable [regexp -all "x" $bitString]
        foreach {mode count} "R $readable W $writable X $executable" {
                if {([string first $mode $modeString] > -1) && !$count} {error "$mode access not allowed"}
        }
        if [string equal $modeString "X W"] {
                if {($writable == 3) && ($executable == 3)} {
                        return
                } elseif [file writable $fileName] {
                        if {[regexp -all "wx" $bitString] == $writable} {
                                return
                        } elseif [file executable $fileName] {
                                return
                        }
                }
        }
        if [string equal $modeString "R W"] {
                if {($writable == 3) && ($readable == 3)} {
                        return
                } elseif [file writable $fileName] {
                        if {[regexp -all "rw" $bitString] == $writable} {
                                return
                        } elseif [file readable $fileName] {
                                return
                        }
                }
        }
        if [string equal $modeString "R X"] {
                if {($readable == 3) && ($executable == 3)} {
                        return
                } elseif [file executable $fileName] {
                        if {[regexp -all {r[w-]x} $bitString] == $executable} {
                                return
                        } elseif [file readable $fileName] {
                                return
                        }
                }
        }

        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 [file tail $fileName] \;] 1]
        if [string equal $timeStamp {}] {
                catch {file delete $fileName} result
                return
        }
        set targetFile [Reconstitute $fileName $path]
        set referenceFiles [glob -directory [file dirname $fileName] -nocomplain *vfs&delta$timeStamp]
        if [catch {::vfs::filesystem info $path}] {append referenceFiles " [glob -directory [file dirname $fileName] -nocomplain -type hidden *vfs&delta$timeStamp]"}
        foreach referenceFile $referenceFiles {
                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 fileNames [glob -nocomplain -path [file join $path $relative] *]
        if [catch {::vfs::filesystem info $path}] {append fileNames " [glob -nocomplain -path [file join $path $relative] -type hidden *]"}
        set fileName [lindex $fileNames 0]
        if [set i [expr [lsearch -exact $fileNames [file join $path $relative]] + 1]] {set fileName [lindex $fileNames [incr i -1]]}
        file attributes $fileName
 }

 proc FileAttributesSet {path root relative actualpath attribute value} {
        set fileNames [glob -nocomplain -path [file join $path $relative] *]
        if [catch {::vfs::filesystem info $path}] {append fileNames " [glob -nocomplain -path [file join $path $relative] -type hidden *]"}
        set fileName [lindex $fileNames 0]
        if [set i [expr [lsearch -exact $fileNames [file join $path $relative]] + 1]] {set fileName [lindex $fileNames [incr i -1]]}
        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]
        if [catch {::vfs::filesystem info $path}] {append globList " [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 fileNames [glob -nocomplain -path [file join $path $relative] *]
        if [catch {::vfs::filesystem info $path}] {append fileNames " [glob -nocomplain -path [file join $path $relative] -type hidden *]"}
        set fileName [lindex $fileNames 0]
        if [set i [expr [lsearch -exact $fileNames [file join $path $relative]] + 1]] {set fileName [lindex $fileNames [incr i -1]]}

        set newFile 0
        if ![file exists $fileName] {set newFile 1}
        set fileName [file join $path $relative]
        set channelID [Reconstitute $fileName $path]
        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
        seek $channelID 0
        fcopy $channelID $f
        close $f
        Delta $fileName $path
        return
 }

 proc RemoveDirectory {path root relative actualpath} {
        catch {file delete [file join $path $relative]}
 }

 proc Stat {path root relative actualpath} {
        set fileNames [glob -nocomplain -path [file join $path $relative] *]
        if [catch {::vfs::filesystem info $path}] {append fileNames " [glob -nocomplain -path [file join $path $relative] -type hidden *]"}
        set fileName [lindex $fileNames 0]
        if [set i [expr [lsearch -exact $fileNames [file join $path $relative]] + 1]] {set fileName [lindex $fileNames [incr i -1]]}
        
        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 fileNames [glob -nocomplain -path [file join $path $relative] *]
        if [catch {::vfs::filesystem info $path}] {append fileNames " [glob -nocomplain -path [file join $path $relative] -type hidden *]"}
        set fileName [lindex $fileNames 0]
        if [set i [expr [lsearch -exact $fileNames [file join $path $relative]] + 1]] {set fileName [lindex $fileNames [incr i -1]]}

        file atime $fileName $atime
        file mtime $fileName $mtime
 }

 proc Delta {filename path} {
        set fileRoot [lindex [split [file tail $filename] \;] 0]
        set fileNames [glob -nocomplain -path [file join [file dirname $filename] $fileRoot] *]
        if [catch {::vfs::filesystem info $path}] {append fileNames " [glob -nocomplain -path [file join [file dirname $filename] $fileRoot] -type hidden *]"}
        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
                array set fileAttributes [file attributes $fileName]
                if [info exists fileAttributes(-readonly)] {catch {file attributes $fileName -readonly 0}}
                if [info exists fileAttributes(-permissions)] {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 equal [array get fileStats $attr] [array get fileAttributes $attr]] {continue}
                        if [string equal "-permissions" $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] {
                if ![file exists $fn] {continue}
                file atime $fn $atimes($fn)
        }
 }

 proc Reconstitute {fileName path} {
        if ![catch {set channelID [open $fileName r]}] {return $channelID}
        if ![catch {set channelID [open $fileName\;vfs&delta r]}] {return $channelID}
        set targetFiles [glob -nocomplain -path $fileName *]
        if [catch {::vfs::filesystem info $path}] {append targetFiles " [glob -nocomplain -path $fileName -type hidden *]"}
        set targetFile [lindex $targetFiles 0]

        set targetFile [string trim $targetFile]
        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 targetFiles [glob -directory [file dirname $fileName] *\;$targetTime*]
                if [catch {::vfs::filesystem info $path}] {append targetFiles " [glob -directory [file dirname $fileName] -nocomplain -type hidden *\;$targetTime*]"}
                set targetFile [lindex $targetFiles 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

• tcl-fuse

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References