Caching VFS

The idea of these two VFS add and cache commands is to allow Plan9-like stacking of mounts - you can mount any directory over any other, and what you see from the mount is a conjunction of the two directories.

cache in addition redirects all modifications to the first directory in the stack, permitting one to cache modifications to (for example) a read-only file system. This could be handy for tclhttpd

Caveats/Warning: It's not completely tested, I haven't tested stacked directories containing subdirectories. It's also very badly documented, but I doubt it'll destroy your disk. Nov12th - new version fixes open semantics.

    #!/usr/bin/tclsh
    #
    # vfs::add::Mount dirlist local
    #  - mounts the directories in $dirlist over local, so they behave as a single directory
    #
    # vfs::cache::Mount dirlist local
    # - as for vfs::add, but all modifications go back to the first directory in the list
    #
    
    package require vfs
    package provide vfs::add 1.1
    
    namespace eval vfs::add {}
    
    proc vfs::add::Mount {dirs local args} {
        # ensure each submount is normalized
        foreach mp [split $dirs] {
            lappend mps [file normalize $mp]
        }
    
        ::vfs::log "add-vfs: attempt to mount $dirs / $mps at $local"
    
        if {[llength $mps] < 2} {
            ::vfs::log "add-vfs: add-vfs names are lists of dirs"
            return -code error "add-vfs names are lists of dirs"
        }
        
        if {![catch {vfs::filesystem info $dirs}]} {
            # unmount old mount
            ::vfs::log "add-vfs: unmounted old mount point at $dirs"
            vfs::unmount $dirs
        }
    
        vfs::filesystem mount $local [list vfs::add::handler $mps]
    
        # Register command to unmount
        vfs::RegisterMount $local [list ::vfs::add::Unmount $mps]
    
        return $mps
    }
    
    proc vfs::add::Unmount {mps local} {
        vfs::filesystem unmount $local
    }
    
    proc vfs::add::handler {mps cmd root relative actualpath args} {
        ::vfs::log "::vfs::add handler $mps [llength $mps] $cmd $relative $actualpath $args"
        if {$cmd == "matchindirectory"} {
            eval [list $cmd $mps $relative $actualpath] $args
        } else {
            eval [list $cmd $mps $relative] $args
        }
    }
    
    # If we implement the commands below, we will have a perfect
    # virtual file system for remote add sites.
    
    proc vfs::add::_find {mps name} {
        foreach mp $mps {
            set shadow [file join $mp $name]
            ::vfs::log "_find $shadow"
            if {[file exists $shadow]} {
                return $shadow
            }
        }
        error "no such file $name"
    }
    
    proc vfs::add::_finddir {mps name} {
        foreach mp $mps {
            set shadow [file join $mp $name]
            ::vfs::log "_find $shadow"
            if {[file exists $shadow]} {
                return $mp
            }
        }
        error "no such file $name"
    }
    
    proc vfs::add::stat {mps name} {
        ::vfs::log "stat $mps $name"
        if {$name == ""} {
            return [file stat [lindex $mps 0]]
        }
    
        # get information on the type of this file
        return [file stat [_find $mps $name]]
    }
    
    proc vfs::add::access {mps name mode} {
        ::vfs::log "add-access $name $mode"
        if {$name == ""} {
            array set stat [file stat [lindex $mps 0]]
            return [expr $stat(mode) & $mode]
        }
    
        # find our file
        array set stat [file stat [_find $mps $name]]
        return [expr $stat(mode) & $mode]
    }
    
    proc vfs::add::open {mps name mode permissions} {
        ::vfs::log "open $name $mode $permissions"
    
        foreach mp $mps {
            set shadow [file join $mp $name]
            if {![catch {::open $shadow $mode $permissions} result]} {
                return $result
            }
        }
        error "open failed $name $mode $permissions"
    }
    
    proc vfs::add::matchindirectory {mps relative actualpath pattern type} {
        ::vfs::log "matchindirectory $mps $relative $actualpath $pattern $type"
    
        foreach mp $mps {
            set shadow [file join $mp $relative]
            if {[file exists $shadow]} {
                set filelist [glob -directory $shadow $pattern]
                set matching [vfs::matchCorrectTypes $type $filelist $mp]
                set preflen [expr [string length $mp] + 1]
                foreach match $matching {
                    set matches([string range $match $preflen end]) 1
                }
            }
        }
        return [array names matches]
    }
    
    proc vfs::add::createdirectory {mps name} {
        ::vfs::log "createdirectory $name"
        file mkdir [file join [lindex $mps 0] $name]
    }
    
    proc vfs::add::removedirectory {mps name} {
        ::vfs::log "removedirectory $name"
    
        foreach mp $mps {
            set shadow [file join $mp $name]
            if {[file exists $shadow]} {
                return [file delete $shadow]
            }
        }
        error "No such file"
    }
    
    proc vfs::add::deletefile {mps name} {
        ::vfs::log "deletefile $name"
        foreach mp $mps {
            set shadow [file join $mp $name]
            if {[file exists $shadow]} {
                return [file delete $shadow]
            }
        }
        error "No such file"
    }
    
    proc vfs::add::fileattributes {mps path args} {
        ::vfs::log "fileattributes $args"
        switch -- [llength $args] {
            0 {
                # list strings
                return [list]
            }
            1 {
                # get value
                set index [lindex $args 0]
            }
            2 {
                # set value
                set index [lindex $args 0]
                set val [lindex $args 1]
            }
        }
    }
    
    proc vfs::add::utime {mps path actime mtime} {
        error "Can't set utime"
    }
    
    namespace eval vfs::cache {}
    
    proc vfs::cache::Mount {dirs local args} {
        # ensure each submount is normalized
        foreach mp [split $dirs] {
            lappend mps [file normalize $mp]
        }
    
        ::vfs::log "cache-vfs: attempt to mount $dirs / $mps at $local"
    
        if {[llength $mps] < 2} {
            ::vfs::log "cache-vfs: cache-vfs names are lists of dirs"
            return -code error "cache-vfs names are lists of dirs"
        }
        
        if {![catch {vfs::filesystem info $dirs}]} {
            # unmount old mount
            ::vfs::log "cache-vfs: unmounted old mount point at $dirs"
            vfs::unmount $dirs
        }
    
        vfs::filesystem mount $local [list vfs::cache::handler $mps]
    
        # Register command to unmount
        vfs::RegisterMount $local [list ::vfs::add::Unmount $mps]
    
        return $mps
    }
    
    proc vfs::cache::handler {mps cmd root relative actualpath args} {
        ::vfs::log "::vfs::cache handler $mps [llength $mps] $cmd $relative $actualpath $args"
        if {$cmd == "matchindirectory"} {
            eval [list ::vfs::add::$cmd $mps $relative $actualpath] $args
        } elseif {$cmd == "open"} {
            eval [list $cmd $mps $relative] $args
        } else {
            eval [list ::vfs::add::$cmd $mps $relative] $args
        }
    }
    
    proc vfs::cache::open {mps name mode permissions} {
        ::vfs::log "open $name $mode $permissions"
        set cache [lindex $mps 0]
        switch -glob $mode {
            r {
                # don't copy.
                return [::open [::vfs::add:_find $mps $name] $mode $permissions]
            }
    
            a* {
                if {[catch {set original [::vfs::add::_find $mps $name]}]} {
                    ::vfs::log "open $mode - original file doesn't exist"
                    # the file doesn't exist - create intervening dirs
                    if {![catch {::vfs::add::_finddir $mps [file dirname $name]}]} {
                        file mkdir [file join $cache [file dirname $name]]
                    }
                } else {
                    ::vfs::log "open $mode - original file $original"
                    
                    # the file exists - create intervening dirs
                    file mkdir [file join $cache [file dirname $name]]
                    
                    # copy the original to cache dir
                    if {[file dirname $original] != [file dirname [file join $cache $name]]} {
                        file copy $original [file join $cache $name]
                    }
                }
            }
    
            r+ {
                # file must exist in one of the dirs
                set original [::vfs::add::_find $mps $name]
    
                # make intervening dirs in cache dir
                file mkdir [file join $cache [file dirname $name]]
    
                # copy original to cache dir
                file copy $original $cache
            }
    
            w* {
                if {![catch {::vfs::add::_finddir $mps [file dirname $name]}]} {
                    file mkdir [file join $cache [file dirname $name]]
                }
                # will create in cache dir and truncate if needed
            }
        }
        return [::open [file join $cache $name] $mode $permissions]
    }
    
    if {$argv0 == [info script]} {
    
        set script [info script]
    
        catch {file mkdir ./t1}
        for {set i 3} {$i} {incr i -1} {
            file copy -force $script ./t1/t1_$i
        }
    
        catch {file mkdir ./t2}
        for {set i 3} {$i} {incr i -1} {
            file copy -force $script ./t2/t2_$i
        }
    
        for {set i 3} {$i} {incr i -1} {
            file copy -force $script ./t1/t0_$i
            file copy -force $script ./t2/t0_$i
        }
    
        vfs::cache::Mount [list ./t1 ./t2] ./T12
    
        puts stderr "[glob ./T12/*]"
    
        set fd [open ./T12/newfile w]
        puts $fd junk
        close $fd
    
        set fd [open ./T12/t2_1 a]
        puts $fd junk
        close $fd
    
        puts stderr "[glob ./T12/*]"
    
        # create a file in a new subdir
        catch {file mkdir ./T12/s1}
        set fd [open ./T12/s1/junk w]
        puts $fd junk
        close $fd
    
        set fd [open ./T12/s1/junk a]
        puts $fd junk
        close $fd
    
        puts stderr "[glob ./T12/*]"
    }

See also Cache VFS